diff --git a/CHANGES.md b/CHANGES.md index 09211056ca..da4dc99f7d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +Additions +- New (experimental!) option `--as-json` for the HTML renderer that emits HTML + fragments (preamble, content) together with metadata (table of contents, + breadcrumbs, whether katex is used) in JSON format. + 2.1.0 ----- diff --git a/src/html/config.ml b/src/html/config.ml index 32c7be3bb5..ea5f93d0f5 100644 --- a/src/html/config.ml +++ b/src/html/config.ml @@ -7,24 +7,12 @@ type t = { indent : bool; flat : bool; open_details : bool; - omit_breadcrumbs : bool; - omit_toc : bool; - content_only : bool; + as_json : bool; } let v ?theme_uri ?support_uri ~semantic_uris ~indent ~flat ~open_details - ~omit_breadcrumbs ~omit_toc ~content_only () = - { - theme_uri; - support_uri; - semantic_uris; - indent; - flat; - open_details; - omit_breadcrumbs; - omit_toc; - content_only; - } + ~as_json () = + { semantic_uris; indent; flat; open_details; theme_uri; support_uri; as_json } let theme_uri config = match config.theme_uri with None -> Types.Relative None | Some uri -> uri @@ -40,8 +28,4 @@ let flat config = config.flat let open_details config = config.open_details -let omit_breadcrumbs config = config.omit_breadcrumbs - -let omit_toc config = config.omit_toc - -let content_only config = config.content_only +let as_json config = config.as_json diff --git a/src/html/config.mli b/src/html/config.mli index 0fb93f48c8..97e941358b 100644 --- a/src/html/config.mli +++ b/src/html/config.mli @@ -9,9 +9,7 @@ val v : indent:bool -> flat:bool -> open_details:bool -> - omit_breadcrumbs:bool -> - omit_toc:bool -> - content_only:bool -> + as_json:bool -> unit -> t @@ -27,8 +25,4 @@ val flat : t -> bool val open_details : t -> bool -val omit_breadcrumbs : t -> bool - -val omit_toc : t -> bool - -val content_only : t -> bool +val as_json : t -> bool diff --git a/src/html/generator.ml b/src/html/generator.ml index a0942f20ca..64f598d80f 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -375,6 +375,29 @@ module Toc = struct List.map section toc end +module Breadcrumbs = struct + open Types + + let gen_breadcrumbs ~config ~url = + let rec get_parent_paths x = + match x with + | [] -> [] + | x :: xs -> ( + match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with + | Some x -> x :: get_parent_paths xs + | None -> get_parent_paths xs) + in + let to_breadcrumb path = + let href = + Link.href ~config ~resolve:(Current url) + (Odoc_document.Url.from_path path) + in + { href; name = path.name; kind = path.kind } + in + get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url)) + |> List.rev |> List.map to_breadcrumb +end + module Page = struct let on_sub = function | `Page _ -> None @@ -399,11 +422,18 @@ module Page = struct let i = Doctree.Shift.compute ~on_sub i in let uses_katex = Doctree.Math.has_math_elements p in let toc = Toc.gen_toc ~config ~resolve ~path:url i in + let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in let header = items ~config ~resolve (Doctree.PageTitle.render_title p @ preamble) in let content = (items ~config ~resolve i :> any Html.elt list) in - Tree.make ~config ~header ~toc ~url ~uses_katex url.name content subpages + if Config.as_json config then + Html_fragment_json.make ~config + ~preamble:(items ~config ~resolve preamble :> any Html.elt list) + ~breadcrumbs ~toc ~url ~uses_katex content subpages + else + Html_page.make ~config ~header ~toc ~breadcrumbs ~url ~uses_katex content + subpages end let render ~config page = Page.page ~config page diff --git a/src/html/html_fragment_json.ml b/src/html/html_fragment_json.ml new file mode 100644 index 0000000000..d5b5d8de48 --- /dev/null +++ b/src/html/html_fragment_json.ml @@ -0,0 +1,55 @@ +(* Rendering of HTML fragments together with metadata. For embedding the + generated documentation in existing websites. +*) + +module Html = Tyxml.Html + +let json_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) : Utils.Json.json + = + let breadcrumb (b : Types.breadcrumb) = + `Object + [ + ("name", `String b.name); + ("href", `String b.href); + ("kind", `String (Odoc_document.Url.Path.string_of_kind b.kind)); + ] + in + let json_breadcrumbs = breadcrumbs |> List.map breadcrumb in + `Array json_breadcrumbs + +let json_of_toc (toc : Types.toc list) : Utils.Json.json = + let rec section (s : Types.toc) = + `Object + [ + ("title", `String s.title_str); + ("href", `String s.href); + ("children", `Array (List.map section s.children)); + ] + in + let toc_json_list = toc |> List.map section in + `Array toc_json_list + +let make ~config ~preamble ~url ~breadcrumbs ~toc ~uses_katex content children = + let filename = Link.Path.as_filename ~is_flat:(Config.flat 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 content ppf = + Format.pp_print_string ppf + (json_to_string + (`Object + [ + ("uses_katex", `Bool uses_katex); + ("breadcrumbs", json_of_breadcrumbs breadcrumbs); + ("toc", json_of_toc toc); + ( "preamble", + `String + (String.concat "" + (List.map (Format.asprintf "%a" htmlpp) preamble)) ); + ( "content", + `String + (String.concat "" + (List.map (Format.asprintf "%a" htmlpp) content)) ); + ])) + in + [ { Odoc_document.Renderer.filename; content; children } ] diff --git a/src/html/html_fragment_json.mli b/src/html/html_fragment_json.mli new file mode 100644 index 0000000000..578dc2cb84 --- /dev/null +++ b/src/html/html_fragment_json.mli @@ -0,0 +1,12 @@ +module Html = Tyxml.Html + +val make : + config:Config.t -> + preamble:Html_types.div_content Html.elt list -> + url:Odoc_document.Url.Path.t -> + breadcrumbs:Types.breadcrumb list -> + toc:Types.toc list -> + uses_katex:bool -> + Html_types.div_content Html.elt list -> + Odoc_document.Renderer.page list -> + Odoc_document.Renderer.page list diff --git a/src/html/tree.ml b/src/html/html_page.ml similarity index 58% rename from src/html/tree.ml rename to src/html/html_page.ml index fc52c0ba35..0fa94b085e 100644 --- a/src/html/tree.ml +++ b/src/html/html_page.ml @@ -18,7 +18,7 @@ module Html = Tyxml.Html let html_of_toc toc = let open Types in - let rec section section = + let rec section (section : toc) = let link = Html.a ~a:[ Html.a_href section.href ] section.title in match section.children with [] -> [ link ] | cs -> [ link; sections cs ] and sections the_sections = @@ -30,13 +30,54 @@ let html_of_toc toc = | [] -> [] | _ -> [ Html.nav ~a:[ Html.a_class [ "odoc-toc" ] ] [ sections toc ] ] -let page_creator ~config ~url ~uses_katex name header toc content = +let html_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) = + let make_navigation ~up_url rest = + [ + Html.nav + ~a:[ Html.a_class [ "odoc-nav" ] ] + ([ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ] + @ rest); + ] + in + match List.rev breadcrumbs with + | [] -> [] (* Can't happen - there's always the current page's breadcrumb. *) + | [ _ ] -> [] (* No parents *) + | [ { name = "index"; _ }; x ] -> + (* Special case leaf pages called 'index' with one parent. This is for files called + index.mld that would otherwise clash with their parent. In particular, + dune and odig both cause this situation right now. *) + let up_url = "../index.html" in + let parent_name = x.name in + make_navigation ~up_url [ Html.txt parent_name ] + | current :: up :: bs -> + let space = Html.txt " " in + let sep = [ space; Html.entity "#x00BB"; space ] in + let html = + (* Create breadcrumbs *) + Utils.list_concat_map ?sep:(Some sep) + ~f:(fun (breadcrumb : Types.breadcrumb) -> + [ + [ + Html.a + ~a:[ Html.a_href breadcrumb.href ] + [ Html.txt breadcrumb.name ]; + ]; + ]) + (up :: bs) + |> List.flatten + in + make_navigation ~up_url:up.href + (List.rev html @ sep @ [ Html.txt current.name ]) + +let page_creator ~config ~url ~uses_katex header breadcrumbs toc content = let theme_uri = Config.theme_uri config in let support_uri = Config.support_uri config in let path = Link.Path.for_printing url in let head : Html_types.head Html.elt = - let title_string = Printf.sprintf "%s (%s)" name (String.concat "." path) in + let title_string = + Printf.sprintf "%s (%s)" url.name (String.concat "." path) + in let file_uri base file = match base with @@ -99,89 +140,20 @@ let page_creator ~config ~url ~uses_katex name header toc content = Html.head (Html.title (Html.txt title_string)) meta_elements in - let gen_breadcrumbs () = - let rec get_parents x = - match x with - | [] -> [] - | x :: xs -> ( - match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with - | Some x -> x :: get_parents xs - | None -> get_parents xs) - in - let parents = - get_parents (List.rev (Odoc_document.Url.Path.to_list url)) |> List.rev - in - let href page = - Link.href ~resolve:(Current url) (Odoc_document.Url.from_path page) - in - let make_navigation ~up_url breadcrumbs = - [ - Html.nav - ~a:[ Html.a_class [ "odoc-nav" ] ] - ([ - Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – "; - ] - @ breadcrumbs); - ] - in - match parents with - | [] -> [] (* Can't happen - Url.Path.to_list returns a non-empty list *) - | [ _ ] -> [] (* No parents *) - | [ x; { name = "index"; _ } ] -> - (* Special case leaf pages called 'index' with one parent. This is for files called - index.mld that would otherwise clash with their parent. In particular, - dune and odig both cause this situation right now. *) - let up_url = "../index.html" in - let parent_name = x.name in - make_navigation ~up_url [ Html.txt parent_name ] - | _ -> - let up_url = href ~config (List.hd (List.tl (List.rev parents))) in - let l = - (* Create breadcrumbs *) - let space = Html.txt " " in - parents - |> Utils.list_concat_map - ?sep:(Some [ space; Html.entity "#x00BB"; space ]) - ~f:(fun url' -> - [ - [ - (if url = url' then Html.txt url.name - else - Html.a - ~a:[ Html.a_href (href ~config url') ] - [ Html.txt url'.name ]); - ]; - ]) - |> List.flatten - in - make_navigation ~up_url l - in - - let breadcrumbs = - if Config.omit_breadcrumbs config then [] else gen_breadcrumbs () - in - let toc = if Config.omit_toc config then [] else html_of_toc toc in let body = - breadcrumbs + html_of_breadcrumbs breadcrumbs @ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ] - @ toc + @ html_of_toc toc @ [ Html.div ~a:[ Html.a_class [ "odoc-content" ] ] content ] in - let htmlpp_elt = Html.pp_elt ~indent:(Config.indent config) () in let htmlpp = Html.pp ~indent:(Config.indent config) () in - if Config.content_only config then - let content ppf = - htmlpp_elt ppf (Html.div ~a:[ Html.a_class [ "odoc" ] ] body) - in - content - else - let html = Html.html head (Html.body ~a:[ Html.a_class [ "odoc" ] ] body) in - let content ppf = htmlpp ppf html in - content + let html = Html.html head (Html.body ~a:[ Html.a_class [ "odoc" ] ] body) in + let content ppf = htmlpp ppf html in + content -let make ~config ~url ~header ~toc ~uses_katex title content children = +let make ~config ~url ~header ~breadcrumbs ~toc ~uses_katex content children = let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in let content = - page_creator ~config ~url ~uses_katex title header toc content + page_creator ~config ~url ~uses_katex header breadcrumbs toc content in [ { Odoc_document.Renderer.filename; content; children } ] diff --git a/src/html/tree.mli b/src/html/html_page.mli similarity index 97% rename from src/html/tree.mli rename to src/html/html_page.mli index 3e78029ee4..f79495f315 100644 --- a/src/html/tree.mli +++ b/src/html/html_page.mli @@ -24,9 +24,9 @@ val make : config:Config.t -> url:Odoc_document.Url.Path.t -> header:Html_types.flow5_without_header_footer Html.elt list -> + breadcrumbs:Types.breadcrumb list -> toc:Types.toc list -> uses_katex:bool -> - string -> Html_types.div_content Html.elt list -> Odoc_document.Renderer.page list -> Odoc_document.Renderer.page list diff --git a/src/html/link.ml b/src/html/link.ml index f028352d05..60e68400f4 100644 --- a/src/html/link.ml +++ b/src/html/link.ml @@ -45,7 +45,7 @@ let rec drop_shared_prefix l1 l2 = | l1 :: l1s, l2 :: l2s when l1 = l2 -> drop_shared_prefix l1s l2s | _, _ -> (l1, l2) -let href ~(config : Config.t) ~resolve t = +let href ~config ~resolve t = let { Url.Anchor.page; anchor; _ } = t in let target_loc = Path.for_linking ~is_flat:(Config.flat config) page in diff --git a/src/html/odoc_html.ml b/src/html/odoc_html.ml index 23ab5cfe96..a93ed9f58c 100644 --- a/src/html/odoc_html.ml +++ b/src/html/odoc_html.ml @@ -1,8 +1,11 @@ module Types = Types module Config = Config -module Tree = Tree -(** @canonical Odoc_html.Tree *) +module Html_fragment_json = Html_fragment_json +(** @canonical Odoc_html.Html_fragment_json *) + +module Html_page = Html_page +(** @canonical Odoc_html.Html_page *) module Generator = Generator module Link = Link diff --git a/src/html/types.ml b/src/html/types.ml index 7b3614c1da..a34c68e6d9 100644 --- a/src/html/types.ml +++ b/src/html/types.ml @@ -8,3 +8,9 @@ type toc = { href : string; children : toc list; } + +type breadcrumb = { + href : string; + name : string; + kind : Odoc_document.Url.Path.kind; +} diff --git a/src/html/types.mli b/src/html/types.mli index 1df1fb1800..04fd5623ad 100644 --- a/src/html/types.mli +++ b/src/html/types.mli @@ -10,3 +10,9 @@ type toc = { href : string; children : toc list; } + +type breadcrumb = { + href : string; + name : string; + kind : Odoc_document.Url.Path.kind; +} diff --git a/src/html/utils.ml b/src/html/utils.ml index 3379703af0..c49a034e23 100644 --- a/src/html/utils.ml +++ b/src/html/utils.ml @@ -12,3 +12,87 @@ let rec list_concat_map ?sep ~f = function match sep with None -> hd @ tl | Some sep -> hd @ (sep :: tl)) 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/odoc/bin/main.ml b/src/odoc/bin/main.ml index ca9a49dac4..e237e95ae5 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -510,36 +510,30 @@ module Odoc_html_args = struct let flat = let doc = - "Output HTML files in 'flat' mode, where the heirarchy of modules / \ + "Output HTML files in 'flat' mode, where the hierarchy of modules / \ module types / classes and class types are reflected in the filenames \ - rather than in the directory structure" + rather than in the directory structure." in Arg.(value & flag & info ~docs ~doc [ "flat" ]) - let omit_breadcrumbs = - let doc = "Don't emit the breadcrumbs navigation element" in - Arg.(value & flag & info ~docs ~doc [ "omit-breadcrumbs" ]) - - let omit_toc = - let doc = "Don't emit the table of contents div" in - Arg.(value & flag & info ~docs ~doc [ "omit-toc" ]) - - let content_only = + let as_json = let doc = - "Only emit the content of the page, not the html, head and body elements" + "EXPERIMENTAL: Output HTML files in 'embeddable json' mode, where HTML \ + fragments (preamble, content) together with metadata (uses_katex, \ + breadcrumbs, table of contents) are emitted in JSON format." in - Arg.(value & flag & info ~docs ~doc [ "content-only" ]) + Arg.(value & flag & info ~doc [ "as-json" ]) let extra_args = let config semantic_uris closed_details indent theme_uri support_uri flat - omit_breadcrumbs omit_toc content_only = + as_json = let open_details = not closed_details in Odoc_html.Config.v ~theme_uri ~support_uri ~semantic_uris ~indent ~flat - ~open_details ~omit_breadcrumbs ~omit_toc ~content_only () + ~open_details ~as_json () in Term.( const config $ semantic_uris $ closed_details $ indent $ theme_uri - $ support_uri $ flat $ omit_breadcrumbs $ omit_toc $ content_only) + $ support_uri $ flat $ as_json) end module Odoc_html = Make_renderer (Odoc_html_args) diff --git a/src/odoc/html_fragment.ml b/src/odoc/html_fragment.ml index a7a9ee0344..cff1441b54 100644 --- a/src/odoc/html_fragment.ml +++ b/src/odoc/html_fragment.ml @@ -26,8 +26,7 @@ let from_mld ~xref_base_uri ~resolver ~output ~warnings_options input = let page = Odoc_document.Comment.to_ir resolved.content in let config = Odoc_html.Config.v ~semantic_uris:false ~indent:false ~flat:false - ~open_details:false ~omit_breadcrumbs:false ~omit_toc:false - ~content_only:false () + ~open_details:false ~as_json:false () in let html = Odoc_html.Generator.doc ~config ~xref_base_uri page in let oc = open_out (Fs.File.to_string output) in diff --git a/test/generators/html_opts.t/run.t b/test/generators/html_opts.t/run.t deleted file mode 100644 index 8ac6d7958f..0000000000 --- a/test/generators/html_opts.t/run.t +++ /dev/null @@ -1,48 +0,0 @@ - $ ocamlc -c -bin-annot test.mli - $ ocamlc -c -bin-annot test2.mli - $ odoc compile --package test test.cmti - $ odoc compile --package test -I . test2.cmti - $ odoc link test.odoc - $ odoc link test2.odoc - $ odoc html-generate test.odocl -o html --indent - -This should have the breadcrumbs in it as a nav with id 'odoc-nav'. Let's also -check it's got the expected content by looking for 'type-t' - - $ grep odoc-nav html/test/Test/index.html -