jon.recoil.org
this repo has no description
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
17open Odoc_utils
18
19module Url = Odoc_document.Url
20module Html = Tyxml.Html
21
22let html_of_toc toc =
23 let open Types in
24 let rec section (section : toc) =
25 let link = Html.a ~a:[ Html.a_href section.href ] section.title in
26 match section.children with [] -> [ link ] | cs -> [ link; sections cs ]
27 and sections the_sections =
28 the_sections
29 |> List.map (fun the_section -> Html.li (section the_section))
30 |> Html.ul
31 in
32 match toc with [] -> [] | _ -> [ sections toc ]
33
34let html_of_search () =
35 let search_bar =
36 Html.(
37 input
38 ~a:[ a_class [ "search-bar" ]; a_placeholder "🔎 Type '/' to search..." ]
39 ())
40 in
41 let snake = Html.(div ~a:[ a_class [ "search-snake" ] ] []) in
42 let search_result = Html.div ~a:[ Html.a_class [ "search-result" ] ] [] in
43 Html.(
44 div ~a:[ a_class [ "search-inner" ] ] [ search_bar; snake; search_result ])
45
46let sidebars ~global_toc ~local_toc =
47 let local_toc =
48 match local_toc with
49 | [] -> []
50 | _ :: _ ->
51 [
52 Html.nav
53 ~a:[ Html.a_class [ "odoc-toc"; "odoc-local-toc" ] ]
54 (html_of_toc local_toc);
55 ]
56 in
57 let global_toc =
58 match global_toc with
59 | None -> []
60 | Some c ->
61 [ Html.nav ~a:[ Html.a_class [ "odoc-toc"; "odoc-global-toc" ] ] c ]
62 in
63 match local_toc @ global_toc with
64 | [] -> []
65 | tocs -> [ Html.div ~a:[ Html.a_class [ "odoc-tocs" ] ] tocs ]
66
67let html_of_breadcrumbs (breadcrumbs : Types.breadcrumbs) =
68 let make_navigation ~up_url rest =
69 let up =
70 match up_url with
71 | None -> []
72 | Some up_url ->
73 [ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ]
74 in
75 [ Html.nav ~a:[ Html.a_class [ "odoc-nav" ] ] (up @ rest) ]
76 in
77 let space = Html.txt " " in
78 let sep = [ space; Html.entity "#x00BB"; space ] in
79 let html =
80 (* Create breadcrumbs *)
81 List.concat_map_sep ~sep
82 ~f:(fun (breadcrumb : Types.breadcrumb) ->
83 match breadcrumb.href with
84 | Some href ->
85 [
86 [
87 Html.a
88 ~a:[ Html.a_href href ]
89 (breadcrumb.name
90 :> Html_types.flow5_without_interactive Html.elt list);
91 ];
92 ]
93 | None ->
94 [ (breadcrumb.name :> Html_types.nav_content_fun Html.elt list) ])
95 breadcrumbs.parents
96 |> List.flatten
97 in
98 let current_name :> Html_types.nav_content_fun Html.elt list =
99 breadcrumbs.current.name
100 in
101 let rest =
102 if List.is_empty breadcrumbs.parents then current_name
103 else html @ sep @ current_name
104 in
105 make_navigation ~up_url:breadcrumbs.up_url
106 (rest :> [< Html_types.nav_content_fun > `A `PCDATA `Wbr ] Html.elt list)
107
108let file_uri ~config ~url (base : Types.uri) file =
109 match base with
110 | Types.Absolute uri -> uri ^ "/" ^ file
111 | Relative uri ->
112 let page = Url.Path.{ kind = `File; parent = uri; name = file } in
113 Link.href ~config ~resolve:(Current url) (Url.from_path page)
114
115let default_meta_elements ~config ~url =
116 let theme_uri = Config.theme_uri config in
117 let odoc_css_uri = file_uri ~config ~url theme_uri "odoc.css" in
118 [
119 Html.meta ~a:[ Html.a_charset "utf-8" ] ();
120 Html.link ~rel:[ `Stylesheet ] ~href:odoc_css_uri ();
121 Html.meta
122 ~a:[ Html.a_name "generator"; Html.a_content "odoc %%VERSION%%" ]
123 ();
124 Html.meta
125 ~a:
126 [
127 Html.a_name "viewport";
128 Html.a_content "width=device-width,initial-scale=1.0";
129 ]
130 ();
131 ]
132
133let page_creator ~config ~url ~uses_katex ~resources ~global_toc header
134 breadcrumbs local_toc content =
135 let theme_uri = Config.theme_uri config in
136 let support_uri = Config.support_uri config in
137 let search_uris = Config.search_uris config in
138 let path = Link.Path.for_printing url in
139
140 let head : Html_types.head Html.elt =
141 let title_string =
142 Printf.sprintf "%s (%s)" url.name (String.concat ~sep:"." path)
143 in
144
145 let file_uri = file_uri ~config ~url in
146 let search_uri uri =
147 match uri with
148 | Types.Absolute uri -> uri
149 | Relative uri ->
150 Link.href ~config ~resolve:(Current url) (Url.from_path uri)
151 in
152 let search_scripts =
153 match search_uris with
154 | [] -> []
155 | _ ->
156 let search_urls = List.map search_uri search_uris in
157 let search_urls =
158 let search_url name = Printf.sprintf "'%s'" name in
159 let search_urls = List.map search_url search_urls in
160 "[" ^ String.concat ~sep:"," search_urls ^ "]"
161 in
162 (* The names of the search scripts are put into a js variable. Then
163 the code in [odoc_search.js] load them into a webworker. *)
164 [
165 Html.script ~a:[]
166 (Html.txt
167 (Format.asprintf
168 {|let base_url = '%s';
169let search_urls = %s;
170|}
171 (let page =
172 Url.Path.{ kind = `File; parent = None; name = "" }
173 in
174 Link.href ~config ~resolve:(Current url)
175 (Url.from_path page))
176 search_urls));
177 Html.script
178 ~a:
179 [
180 Html.a_src (file_uri support_uri "odoc_search.js");
181 Html.a_defer ();
182 ]
183 (Html.txt "");
184 ]
185 in
186 (* Deduplicate resources while preserving order (keep first occurrence) *)
187 let deduplicate_resources resources =
188 let rec aux seen acc = function
189 | [] -> List.rev acc
190 | r :: rest ->
191 if List.mem r seen then aux seen acc rest
192 else aux (r :: seen) (r :: acc) rest
193 in
194 aux [] [] resources
195 in
196 (* Convert extension resources to HTML elements *)
197 let extension_resources =
198 let open Odoc_extension_registry in
199 let is_absolute_url url =
200 String.is_prefix ~affix:"http://" url ||
201 String.is_prefix ~affix:"https://" url
202 in
203 let resources = deduplicate_resources resources in
204 List.concat_map
205 (function
206 | Js_url url ->
207 let resolved_url =
208 if is_absolute_url url then url
209 else file_uri support_uri url
210 in
211 [ Html.script ~a:[ Html.a_src resolved_url ] (Html.txt "") ]
212 | Css_url url ->
213 let resolved_url =
214 if is_absolute_url url then url
215 else file_uri support_uri url
216 in
217 [ Html.link ~rel:[ `Stylesheet ] ~href:resolved_url () ]
218 | Js_inline code ->
219 [ Html.script (Html.cdata_script code) ]
220 | Css_inline code ->
221 [ Html.style [ Html.cdata_style code ] ])
222 resources
223 in
224 let extra_css_links =
225 List.map
226 (fun href -> Html.link ~rel:[ `Stylesheet ] ~href ())
227 (Config.extra_css config)
228 in
229 let meta_elements =
230 let highlightjs_meta =
231 let highlight_js_uri = file_uri support_uri "highlight.pack.js" in
232 [
233 Html.script ~a:[ Html.a_src highlight_js_uri ] (Html.txt "");
234 Html.script (Html.txt "hljs.initHighlightingOnLoad();");
235 ]
236 in
237 let katex_meta =
238 if uses_katex then
239 let katex_css_uri = file_uri theme_uri "katex.min.css" in
240 let katex_js_uri = file_uri support_uri "katex.min.js" in
241 [
242 Html.link ~rel:[ `Stylesheet ] ~href:katex_css_uri ();
243 Html.script ~a:[ Html.a_src katex_js_uri ] (Html.txt "");
244 Html.script
245 (Html.cdata_script
246 {|
247 document.addEventListener("DOMContentLoaded", function () {
248 var macros = {};
249 var elements = Array.from(document.getElementsByClassName("odoc-katex-math"));
250 for (var i = 0; i < elements.length; i++) {
251 var el = elements[i];
252 var content = el.textContent;
253 var new_el = document.createElement("span");
254 new_el.setAttribute("class", "odoc-katex-math-rendered");
255 var display = el.classList.contains("display");
256 katex.render(content, new_el, { throwOnError: false, displayMode: display, macros });
257 el.replaceWith(new_el);
258 }
259 });
260 |});
261 ]
262 else []
263 in
264 default_meta_elements ~config ~url @ highlightjs_meta @ katex_meta
265 @ extension_resources @ extra_css_links
266 in
267 let meta_elements = meta_elements @ search_scripts in
268 Html.head (Html.title (Html.txt title_string)) meta_elements
269 in
270 let search_bar =
271 match search_uris with
272 | [] -> []
273 | _ ->
274 [ Html.div ~a:[ Html.a_class [ "odoc-search" ] ] [ html_of_search () ] ]
275 in
276
277 let body =
278 html_of_breadcrumbs breadcrumbs
279 @ search_bar
280 @ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ]
281 @ sidebars ~global_toc ~local_toc
282 @ [ Html.div ~a:[ Html.a_class [ "odoc-content" ] ] content ]
283 in
284
285 let htmlpp = Html.pp ~indent:(Config.indent config) () in
286 let html = Html.html head (Html.body ~a:[ Html.a_class [ "odoc" ] ] body) in
287 let content ppf =
288 htmlpp ppf html;
289 (* Tyxml's pp doesn't output a newline a the end, so we force one *)
290 Format.pp_force_newline ppf ()
291 in
292 content
293
294let make ~config ~url ~header ~breadcrumbs ~sidebar ~toc ~uses_katex ~resources
295 ~assets content children =
296 let filename = Link.Path.as_filename ~config url in
297 let content =
298 page_creator ~config ~url ~uses_katex ~resources ~global_toc:sidebar header
299 breadcrumbs toc content
300 in
301 { Odoc_document.Renderer.filename; content; children; path = url; assets }
302
303let path_of_module_of_source ppf url =
304 match url.Url.Path.parent with
305 | Some parent ->
306 let path = Link.Path.for_printing parent in
307 Format.fprintf ppf " (%s)" (String.concat ~sep:"." path)
308 | None -> ()
309
310let src_page_creator ~breadcrumbs ~config ~url ~header ~sidebar name content =
311 let head : Html_types.head Html.elt =
312 let title_string =
313 Format.asprintf "Source: %s%a" name path_of_module_of_source url
314 in
315 let meta_elements = default_meta_elements ~config ~url in
316 Html.head (Html.title (Html.txt title_string)) meta_elements
317 in
318 let body =
319 html_of_breadcrumbs breadcrumbs
320 @ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ]
321 @ sidebars ~global_toc:sidebar ~local_toc:[]
322 @ content
323 in
324 (* We never indent as there is a bug in tyxml and it would break lines inside
325 a [pre] *)
326 let htmlpp = Html.pp ~indent:false () in
327 let html =
328 Html.html head (Html.body ~a:[ Html.a_class [ "odoc-src" ] ] body)
329 in
330 let content ppf =
331 htmlpp ppf html;
332 (* Tyxml's pp doesn't output a newline a the end, so we force one *)
333 Format.pp_force_newline ppf ()
334 in
335 content
336
337let make_src ~config ~url ~breadcrumbs ~header ~sidebar title content =
338 let filename = Link.Path.as_filename ~config url in
339 let content =
340 src_page_creator ~breadcrumbs ~config ~url ~header ~sidebar title content
341 in
342 { Odoc_document.Renderer.filename; content; children = []; path = url; assets = [] }
343
344(* Register as the default shell *)
345let () =
346 Html_shell.register
347 (module struct
348 let name = "default"
349
350 let make ~config (data : Html_shell.page_data) =
351 make ~config ~url:data.url
352 ~header:(data.header @ data.preamble)
353 ~breadcrumbs:data.breadcrumbs ~sidebar:data.sidebar ~toc:data.toc
354 ~uses_katex:data.uses_katex ~resources:data.resources
355 ~assets:data.assets data.content data.children
356
357 let make_src ~config (data : Html_shell.src_page_data) =
358 make_src ~config ~url:data.url ~breadcrumbs:data.breadcrumbs
359 ~header:data.header ~sidebar:data.sidebar data.title data.content
360 end)