2108

Committed 03 Jul 2024 07:23AM UTC coverage: 71.946% (+0.2%) from 71.774%

Build # 2108

Build Type

Pull #1145

github

Committed by

web-flow

Commit Message

Merge 0b753d1e4 into 7e1e6ac92

Pull Request Pull Request #1145: "Global" Sidebar

Run Details

197 of 230 new or added lines in 12 files covered. (85.65%)

627 existing lines in 13 files now uncovered.

9835 of 13670 relevant lines covered (71.95%)

3555.77 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

97.64

/src/html/html_page.ml

(*
 * Copyright (c) 2016 Thomas Refis <trefis@janestreet.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

module Url = Odoc_document.Url
module Html = Tyxml.Html

let html_of_toc toc =
  let open Types in
  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 =
    the_sections
    |> List.map (fun the_section -> Html.li (section the_section))
    |> Html.ul
  in
  match toc with [] -> [] | _ -> [ sections toc ]

let html_of_search () =
  let search_bar =
    Html.(
      input
        ~a:[ a_class [ "search-bar" ]; a_placeholder "🔎 Type '/' to search..." ]
        ())
  in
  let snake = Html.(div ~a:[ a_class [ "search-snake" ] ] []) in
  let search_result = Html.div ~a:[ Html.a_class [ "search-result" ] ] [] in
  Html.(
    div ~a:[ a_class [ "search-inner" ] ] [ search_bar; snake; search_result ])

let sidebar ~sb toc =
  let sidebar c = [ Html.div ~a:[ Html.a_class [ "odoc-tocs" ] ] c ] in
  match sb with
  | None -> (
      match toc with
      | [] -> []
      | _ ->
          sidebar
            [
              Html.nav
                ~a:[ Html.a_class [ "odoc-toc"; "odoc-local-toc" ] ]
                (html_of_toc toc);
            ])
  | Some c ->
      sidebar
        [
          Html.nav
            ~a:[ Html.a_class [ "odoc-toc"; "odoc-local-toc" ] ]
            (html_of_toc toc);
          Html.nav ~a:[ Html.a_class [ "odoc-toc"; "odoc-global-toc" ] ] c;
        ]

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 file_uri ~config ~url (base : Types.uri) file =
  match base with
  | Types.Absolute uri -> uri ^ "/" ^ file
  | Relative uri ->
      let page = Url.Path.{ kind = `File; parent = uri; name = file } in
      Link.href ~config ~resolve:(Current url) (Url.from_path page)

let default_meta_elements ~config ~url =
  let theme_uri = Config.theme_uri config in
  let odoc_css_uri = file_uri ~config ~url theme_uri "odoc.css" in
  [
    Html.meta ~a:[ Html.a_charset "utf-8" ] ();
    Html.link ~rel:[ `Stylesheet ] ~href:odoc_css_uri ();
    Html.meta
      ~a:[ Html.a_name "generator"; Html.a_content "odoc %%VERSION%%" ]
      ();
    Html.meta
      ~a:
        [
          Html.a_name "viewport";
          Html.a_content "width=device-width,initial-scale=1.0";
        ]
      ();
  ]

let page_creator ~config ~url ~uses_katex ~sb header breadcrumbs toc content =
  let theme_uri = Config.theme_uri config in
  let support_uri = Config.support_uri config in
  let search_uris = Config.search_uris config in
  let path = Link.Path.for_printing url in

  let head : Html_types.head Html.elt =
    let title_string =
      Printf.sprintf "%s (%s)" url.name (String.concat "." path)
    in

    let file_uri = file_uri ~config ~url in
    let search_uri uri =
      match uri with
      | Types.Absolute uri -> uri
      | Relative uri ->
          Link.href ~config ~resolve:(Current url) (Url.from_path uri)
    in
    let search_scripts =
      match search_uris with
      | [] -> []
      | _ ->
          let search_urls = List.map search_uri search_uris in
          let search_urls =
            let search_url name = Printf.sprintf "'%s'" name in
            let search_urls = List.map search_url search_urls in
            "[" ^ String.concat "," search_urls ^ "]"
          in
          (* The names of the search scripts are put into a js variable. Then
             the code in [odoc_search.js] load them into a webworker. *)
          [
            Html.script ~a:[]
              (Html.txt
                 (Format.asprintf
                    {|let base_url = '%s';
let search_urls = %s;
|}
                    (let page =
                       Url.Path.{ kind = `File; parent = None; name = "" }
                     in
                     Link.href ~config ~resolve:(Current url)
                       (Url.from_path page))
                    search_urls));
            Html.script
              ~a:
                [
                  Html.a_src (file_uri support_uri "odoc_search.js");
                  Html.a_defer ();
                ]
              (Html.txt "");
          ]
    in
    let meta_elements =
      let highlightjs_meta =
        let highlight_js_uri = file_uri support_uri "highlight.pack.js" in
        [
          Html.script ~a:[ Html.a_src highlight_js_uri ] (Html.txt "");
          Html.script (Html.txt "hljs.initHighlightingOnLoad();");
        ]
      in
      let katex_meta =
        if uses_katex then
          let katex_css_uri = file_uri theme_uri "katex.min.css" in
          let katex_js_uri = file_uri support_uri "katex.min.js" in
          [
            Html.link ~rel:[ `Stylesheet ] ~href:katex_css_uri ();
            Html.script ~a:[ Html.a_src katex_js_uri ] (Html.txt "");
            Html.script
              (Html.cdata_script
                 {|
          document.addEventListener("DOMContentLoaded", function () {
            var elements = Array.from(document.getElementsByClassName("odoc-katex-math"));
            for (var i = 0; i < elements.length; i++) {
              var el = elements[i];
              var content = el.textContent;
              var new_el = document.createElement("span");
              new_el.setAttribute("class", "odoc-katex-math-rendered");
              var display = el.classList.contains("display");
              katex.render(content, new_el, { throwOnError: false, displayMode: display });
              el.replaceWith(new_el);
            }
          });
        |});
          ]
        else []
      in
      default_meta_elements ~config ~url @ highlightjs_meta @ katex_meta
    in
    let meta_elements = meta_elements @ search_scripts in
    Html.head (Html.title (Html.txt title_string)) meta_elements
  in
  let search_bar =
    match search_uris with
    | [] -> []
    | _ ->
        [ Html.div ~a:[ Html.a_class [ "odoc-search" ] ] [ html_of_search () ] ]
  in

  let body =
    html_of_breadcrumbs breadcrumbs
    @ search_bar
    @ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ]
    @ sidebar ~sb toc
    @ [ Html.div ~a:[ Html.a_class [ "odoc-content" ] ] content ]
  in

  let htmlpp = Html.pp ~indent:(Config.indent config) () in
  let html = Html.html head (Html.body ~a:[ Html.a_class [ "odoc" ] ] body) in
  let content ppf =
    htmlpp ppf html;
    (* Tyxml's pp doesn't output a newline a the end, so we force one *)
    Format.pp_force_newline ppf ()
  in
  content

let make ~config ~url ~header ~breadcrumbs ~sidebar ~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 ~sb:sidebar header breadcrumbs toc
      content
  in
  { Odoc_document.Renderer.filename; content; children }

let path_of_module_of_source ppf url =
  match url.Url.Path.parent with
  | Some parent ->
      let path = Link.Path.for_printing parent in
      Format.fprintf ppf " (%s)" (String.concat "." path)
  | None -> ()

let src_page_creator ~breadcrumbs ~config ~url ~header name content =
  let head : Html_types.head Html.elt =
    let title_string =
      Format.asprintf "Source: %s%a" name path_of_module_of_source url
    in
    let meta_elements = default_meta_elements ~config ~url in
    Html.head (Html.title (Html.txt title_string)) meta_elements
  in
  let body =
    html_of_breadcrumbs breadcrumbs
    @ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ]
    @ content
  in
  (* We never indent as there is a bug in tyxml and it would break lines inside
     a [pre] *)
  let htmlpp = Html.pp ~indent:false () in
  let html =
    Html.html head (Html.body ~a:[ Html.a_class [ "odoc-src" ] ] body)
  in
  let content ppf =
    htmlpp ppf html;
    (* Tyxml's pp doesn't output a newline a the end, so we force one *)
    Format.pp_force_newline ppf ()
  in
  content

let make_src ~config ~url ~breadcrumbs ~header title content =
  let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
  let content =
    src_page_creator ~breadcrumbs ~config ~url ~header title content
  in
  { Odoc_document.Renderer.filename; content; children = [] }

1	(*
2	* Copyright (c) 2016 Thomas Refis <trefis@janestreet.com>
3	*
4	* Permission to use, copy, modify, and distribute this software for any
5	* purpose with or without fee is hereby granted, provided that the above
6	* copyright notice and this permission notice appear in all copies.
7	*
8	* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9	* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10	* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11	* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12	* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13	* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14	* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15	*)
16
17	module Url = Odoc_document.Url
18	module Html = Tyxml.Html
19
20	let html_of_toc toc =
21	let open Types in	114✔
22	let rec section (section : toc) =
23	let link = Html.a ~a:[ Html.a_href section.href ] section.title in	300✔
24	match section.children with [] -> [ link ] \| cs -> [ link; sections cs ]	36✔
25	and sections the_sections =
26	the_sections	145✔
27	\|> List.map (fun the_section -> Html.li (section the_section))	300✔
28	\|> Html.ul	145✔
29	in
30	match toc with [] -> [] \| _ -> [ sections toc ]	5✔
31
32	let html_of_search () =
33	let search_bar =	11✔
34	Html.(
35	input	11✔
36	~a:[ a_class [ "search-bar" ]; a_placeholder "🔎 Type '/' to search..." ]	11✔
37	())
38	in
39	let snake = Html.(div ~a:[ a_class [ "search-snake" ] ] []) in	11✔
40	let search_result = Html.div ~a:[ Html.a_class [ "search-result" ] ] [] in	11✔
41	Html.(	11✔
42	div ~a:[ a_class [ "search-inner" ] ] [ search_bar; snake; search_result ])	11✔
43
44	let sidebar ~sb toc =
45	let sidebar c = [ Html.div ~a:[ Html.a_class [ "odoc-tocs" ] ] c ] in	114✔
46	match sb with
47	\| None -> (	964✔
48	match toc with
49	\| [] -> []	855✔
50	\| _ ->	109✔
51	sidebar
52	[
53	Html.nav	109✔
54	~a:[ Html.a_class [ "odoc-toc"; "odoc-local-toc" ] ]	109✔
55	(html_of_toc toc);	109✔
56	])
57	\| Some c ->	5✔
58	sidebar
59	[
60	Html.nav	5✔
61	~a:[ Html.a_class [ "odoc-toc"; "odoc-local-toc" ] ]	5✔
62	(html_of_toc toc);	5✔
63	Html.nav ~a:[ Html.a_class [ "odoc-toc"; "odoc-global-toc" ] ] c;	5✔
64	]
65
66	let html_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) =
67	let make_navigation ~up_url rest =	991✔
68	[	873✔
69	Html.nav	873✔
70	~a:[ Html.a_class [ "odoc-nav" ] ]	873✔
71	([ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ]	873✔
72	@ rest);
73	]
74	in
75	match List.rev breadcrumbs with
UNCOV 76	\| [] -> [] (* Can't happen - there's always the current page's breadcrumb. *)	×
77	\| [ _ ] -> [] (* No parents *)	118✔
78	\| [ { name = "index"; _ }; x ] ->	2✔
79	(* Special case leaf pages called 'index' with one parent. This is for files called
80	index.mld that would otherwise clash with their parent. In particular,
81	dune and odig both cause this situation right now. *)
82	let up_url = "../index.html" in
83	let parent_name = x.name in
84	make_navigation ~up_url [ Html.txt parent_name ]	2✔
85	\| current :: up :: bs ->	871✔
86	let space = Html.txt " " in
87	let sep = [ space; Html.entity "#x00BB"; space ] in	871✔
88	let html =
89	(* Create breadcrumbs *)
90	Utils.list_concat_map ?sep:(Some sep)
91	~f:(fun (breadcrumb : Types.breadcrumb) ->
92	[	1,494✔
93	[
94	Html.a	1,494✔
95	~a:[ Html.a_href breadcrumb.href ]	1,494✔
96	[ Html.txt breadcrumb.name ];	1,494✔
97	];
98	])
99	(up :: bs)
100	\|> List.flatten	871✔
101	in
102	make_navigation ~up_url:up.href	871✔
103	(List.rev html @ sep @ [ Html.txt current.name ])	871✔
104
105	let file_uri ~config ~url (base : Types.uri) file =
106	match base with	1,979✔
UNCOV 107	\| Types.Absolute uri -> uri ^ "/" ^ file	×
108	\| Relative uri ->	1,979✔
109	let page = Url.Path.{ kind = `File; parent = uri; name = file } in
110	Link.href ~config ~resolve:(Current url) (Url.from_path page)	1,979✔
111
112	let default_meta_elements ~config ~url =
113	let theme_uri = Config.theme_uri config in	991✔
114	let odoc_css_uri = file_uri ~config ~url theme_uri "odoc.css" in	991✔
115	[	991✔
116	Html.meta ~a:[ Html.a_charset "utf-8" ] ();	991✔
117	Html.link ~rel:[ `Stylesheet ] ~href:odoc_css_uri ();	991✔
118	Html.meta	991✔
119	~a:[ Html.a_name "generator"; Html.a_content "odoc %%VERSION%%" ]	991✔
120	();
121	Html.meta	991✔
122	~a:
123	[
124	Html.a_name "viewport";	991✔
125	Html.a_content "width=device-width,initial-scale=1.0";	991✔
126	]
127	();
128	]
129
130	let page_creator ~config ~url ~uses_katex ~sb header breadcrumbs toc content =
131	let theme_uri = Config.theme_uri config in	969✔
132	let support_uri = Config.support_uri config in	969✔
133	let search_uris = Config.search_uris config in	969✔
134	let path = Link.Path.for_printing url in	969✔
135
136	let head : Html_types.head Html.elt =	969✔
137	let title_string =
138	Printf.sprintf "%s (%s)" url.name (String.concat "." path)	969✔
139	in
140
141	let file_uri = file_uri ~config ~url in	969✔
142	let search_uri uri =
143	match uri with	17✔
144	\| Types.Absolute uri -> uri	2✔
145	\| Relative uri ->	15✔
146	Link.href ~config ~resolve:(Current url) (Url.from_path uri)	15✔
147	in
148	let search_scripts =
149	match search_uris with
150	\| [] -> []	958✔
151	\| _ ->	11✔
152	let search_urls = List.map search_uri search_uris in
153	let search_urls =	11✔
154	let search_url name = Printf.sprintf "'%s'" name in	17✔
155	let search_urls = List.map search_url search_urls in
156	"[" ^ String.concat "," search_urls ^ "]"	11✔
157	in
158	(* The names of the search scripts are put into a js variable. Then
159	the code in [odoc_search.js] load them into a webworker. *)
160	[
161	Html.script ~a:[]	11✔
162	(Html.txt	11✔
163	(Format.asprintf	11✔
164	{\|let base_url = '%s';
165	let search_urls = %s;
166	\|}
167	(let page =
168	Url.Path.{ kind = `File; parent = None; name = "" }
169	in
170	Link.href ~config ~resolve:(Current url)	11✔
171	(Url.from_path page))	11✔
172	search_urls));
173	Html.script	11✔
174	~a:
175	[
176	Html.a_src (file_uri support_uri "odoc_search.js");	11✔
177	Html.a_defer ();	11✔
178	]
179	(Html.txt "");	11✔
180	]
181	in
182	let meta_elements =
183	let highlightjs_meta =
184	let highlight_js_uri = file_uri support_uri "highlight.pack.js" in
185	[	969✔
186	Html.script ~a:[ Html.a_src highlight_js_uri ] (Html.txt "");	969✔
187	Html.script (Html.txt "hljs.initHighlightingOnLoad();");	969✔
188	]
189	in
190	let katex_meta =
191	if uses_katex then
192	let katex_css_uri = file_uri theme_uri "katex.min.css" in	4✔
193	let katex_js_uri = file_uri support_uri "katex.min.js" in	4✔
194	[	4✔
195	Html.link ~rel:[ `Stylesheet ] ~href:katex_css_uri ();	4✔
196	Html.script ~a:[ Html.a_src katex_js_uri ] (Html.txt "");	4✔
197	Html.script	4✔
198	(Html.cdata_script	4✔
199	{\|
200	document.addEventListener("DOMContentLoaded", function () {
201	var elements = Array.from(document.getElementsByClassName("odoc-katex-math"));
202	for (var i = 0; i < elements.length; i++) {
203	var el = elements[i];
204	var content = el.textContent;
205	var new_el = document.createElement("span");
206	new_el.setAttribute("class", "odoc-katex-math-rendered");
207	var display = el.classList.contains("display");
208	katex.render(content, new_el, { throwOnError: false, displayMode: display });
209	el.replaceWith(new_el);
210	}
211	});
212	\|});
213	]
214	else []	965✔
215	in
216	default_meta_elements ~config ~url @ highlightjs_meta @ katex_meta
217	in
218	let meta_elements = meta_elements @ search_scripts in
219	Html.head (Html.title (Html.txt title_string)) meta_elements	969✔
220	in
221	let search_bar =
222	match search_uris with
223	\| [] -> []	958✔
224	\| _ ->	11✔
225	[ Html.div ~a:[ Html.a_class [ "odoc-search" ] ] [ html_of_search () ] ]	11✔
226	in
227
228	let body =
229	html_of_breadcrumbs breadcrumbs	969✔
230	@ search_bar
231	@ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ]	969✔
232	@ sidebar ~sb toc	969✔
233	@ [ Html.div ~a:[ Html.a_class [ "odoc-content" ] ] content ]	969✔
234	in
235
236	let htmlpp = Html.pp ~indent:(Config.indent config) () in	969✔
237	let html = Html.html head (Html.body ~a:[ Html.a_class [ "odoc" ] ] body) in	969✔
238	let content ppf =	969✔
239	htmlpp ppf html;	576✔
240	(* Tyxml's pp doesn't output a newline a the end, so we force one *)
241	Format.pp_force_newline ppf ()	576✔
242	in
243	content
244
245	let make ~config ~url ~header ~breadcrumbs ~sidebar ~toc ~uses_katex content
246	children =
247	let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in	969✔
248	let content =	969✔
249	page_creator ~config ~url ~uses_katex ~sb:sidebar header breadcrumbs toc
250	content
251	in
252	{ Odoc_document.Renderer.filename; content; children }	969✔
253
254	let path_of_module_of_source ppf url =
255	match url.Url.Path.parent with	22✔
256	\| Some parent ->	22✔
257	let path = Link.Path.for_printing parent in
258	Format.fprintf ppf " (%s)" (String.concat "." path)	22✔
259	\| None -> ()	×
260
261	let src_page_creator ~breadcrumbs ~config ~url ~header name content =
262	let head : Html_types.head Html.elt =	22✔
263	let title_string =
264	Format.asprintf "Source: %s%a" name path_of_module_of_source url
265	in
266	let meta_elements = default_meta_elements ~config ~url in	22✔
267	Html.head (Html.title (Html.txt title_string)) meta_elements	22✔
268	in
269	let body =
270	html_of_breadcrumbs breadcrumbs	22✔
271	@ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ]	22✔
272	@ content
273	in
274	(* We never indent as there is a bug in tyxml and it would break lines inside
275	a [pre] *)
276	let htmlpp = Html.pp ~indent:false () in
277	let html =	22✔
278	Html.html head (Html.body ~a:[ Html.a_class [ "odoc-src" ] ] body)	22✔
279	in
280	let content ppf =	22✔
281	htmlpp ppf html;	20✔
282	(* Tyxml's pp doesn't output a newline a the end, so we force one *)
283	Format.pp_force_newline ppf ()	20✔
284	in
285	content
286
287	let make_src ~config ~url ~breadcrumbs ~header title content =
288	let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in	22✔
289	let content =	22✔
290	src_page_creator ~breadcrumbs ~config ~url ~header title content
291	in
292	{ Odoc_document.Renderer.filename; content; children = [] }	22✔

ocaml / odoc / 2108

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous