jon.recoil.org
this repo has no description
1(*
2 * Copyright (c) 2016, 2017 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
18open Types
19module Comment = Odoc_model.Comment
20open Odoc_model.Names
21
22let default_lang_tag = "ocaml"
23
24(** Resource collection for extension handlers.
25 Resources are collected during document generation and retrieved when
26 building the final page. *)
27module Resources = struct
28 let collected : Odoc_extension_registry.resource list ref = ref []
29
30 let add resources =
31 collected := !collected @ resources
32
33 let take () =
34 let result = !collected in
35 collected := [];
36 result
37
38 let clear () =
39 collected := []
40end
41
42(** Asset collection for extension handlers.
43 Assets (binary files like PNGs) are collected during document generation
44 and written alongside the HTML output. *)
45module Assets = struct
46 let collected : Odoc_extension_registry.asset list ref = ref []
47
48 let add assets =
49 collected := !collected @ assets
50
51 let take () =
52 let result = !collected in
53 collected := [];
54 result
55
56 let clear () =
57 collected := []
58end
59
60let source_of_code s =
61 if s = "" then [] else [ Source.Elt [ inline @@ Inline.Text s ] ]
62
63module Reference = struct
64 open Odoc_model.Paths
65
66 let rec render_resolved : Reference.Resolved.t -> string =
67 fun r ->
68 let open Reference.Resolved in
69 match r with
70 | `Identifier id -> Identifier.name id
71 | `Alias (_, r) -> render_resolved (r :> t)
72 | `AliasModuleType (_, r) -> render_resolved (r :> t)
73 | `Module (r, s) -> render_resolved (r :> t) ^ "." ^ ModuleName.to_string s
74 | `Hidden p -> render_resolved (p :> t)
75 | `ModuleType (r, s) ->
76 render_resolved (r :> t) ^ "." ^ ModuleTypeName.to_string s
77 | `Type (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s
78 | `Constructor (r, s) ->
79 render_resolved (r :> t) ^ "." ^ ConstructorName.to_string s
80 | `PolyConstructor (r, s) ->
81 render_resolved (r :> t) ^ ".`" ^ ConstructorName.to_string s
82 | `Field (r, s) -> render_resolved (r :> t) ^ "." ^ FieldName.to_string s
83 | `UnboxedField (r, s) -> render_resolved (r :> t) ^ "." ^ UnboxedFieldName.to_string s
84 | `Extension (r, s) ->
85 render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s
86 | `ExtensionDecl (r, _, s) ->
87 render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s
88 | `Exception (r, s) ->
89 render_resolved (r :> t) ^ "." ^ ExceptionName.to_string s
90 | `Value (r, s) -> render_resolved (r :> t) ^ "." ^ ValueName.to_string s
91 | `Class (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s
92 | `ClassType (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s
93 | `Method (r, s) ->
94 (* CR trefis: do we really want to print anything more than [s] here? *)
95 render_resolved (r :> t) ^ "." ^ MethodName.to_string s
96 | `InstanceVariable (r, s) ->
97 (* CR trefis: the following makes no sense to me... *)
98 render_resolved (r :> t) ^ "." ^ InstanceVariableName.to_string s
99 | `Label (_, s) -> LabelName.to_string s
100
101 let render_path (tag, cs) =
102 let tag =
103 match tag with
104 | `TRelativePath -> "./"
105 | `TAbsolutePath -> "/"
106 | `TCurrentPackage -> "//"
107 in
108 tag ^ String.concat ~sep:"/" cs
109
110 let rec render_unresolved : Reference.t -> string =
111 let open Reference in
112 function
113 | `Resolved r -> render_resolved r
114 | `Root (n, _) -> n
115 | `Dot (p, f) -> render_unresolved (p :> t) ^ "." ^ f
116 | `Page_path p -> render_path p
117 | `Asset_path p -> render_path p
118 | `Module_path p -> render_path p
119 | `Any_path p -> render_path p
120 | `Module (p, f) ->
121 render_unresolved (p :> t) ^ "." ^ ModuleName.to_string f
122 | `ModuleType (p, f) ->
123 render_unresolved (p :> t) ^ "." ^ ModuleTypeName.to_string f
124 | `Type (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
125 | `Constructor (p, f) ->
126 render_unresolved (p :> t) ^ "." ^ ConstructorName.to_string f
127 | `Field (p, f) -> render_unresolved (p :> t) ^ "." ^ FieldName.to_string f
128 | `UnboxedField (p, f) -> render_unresolved (p :> t) ^ "." ^ UnboxedFieldName.to_string f
129 | `Extension (p, f) ->
130 render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
131 | `ExtensionDecl (p, f) ->
132 render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
133 | `Exception (p, f) ->
134 render_unresolved (p :> t) ^ "." ^ ExceptionName.to_string f
135 | `Value (p, f) -> render_unresolved (p :> t) ^ "." ^ ValueName.to_string f
136 | `Class (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
137 | `ClassType (p, f) ->
138 render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
139 | `Method (p, f) ->
140 render_unresolved (p :> t) ^ "." ^ MethodName.to_string f
141 | `InstanceVariable (p, f) ->
142 render_unresolved (p :> t) ^ "." ^ InstanceVariableName.to_string f
143 | `Label (p, f) -> render_unresolved (p :> t) ^ "." ^ LabelName.to_string f
144
145 (* This is the entry point. *)
146 let to_ir : ?text:Inline.t -> Reference.t -> Inline.t =
147 fun ?text ref ->
148 match ref with
149 | `Resolved r ->
150 (* IDENTIFIER MUST BE RENAMED TO DEFINITION. *)
151 let id = Reference.Resolved.identifier r in
152 let rendered = render_resolved r in
153 let content =
154 match text with
155 | None -> [ inline @@ Inline.Source (source_of_code rendered) ]
156 | Some s -> s
157 and tooltip =
158 (* Add a tooltip if the content is not the rendered reference. *)
159 match text with
160 | None -> None
161 | Some _ -> Some rendered
162 in
163 let target =
164 match id with
165 | Some id ->
166 let url = Url.from_identifier ~stop_before:false id in
167 Target.Internal (Resolved url)
168 | None -> Internal Unresolved
169 in
170 let link = { Link.target; content; tooltip } in
171 [ inline @@ Inline.Link link ]
172 | _ -> (
173 let s = render_unresolved ref in
174 match text with
175 | None ->
176 let s = source_of_code s in
177 [ inline @@ Inline.Source s ]
178 | Some content ->
179 let link =
180 { Link.target = Internal Unresolved; content; tooltip = Some s }
181 in
182 [ inline @@ Inline.Link link ])
183end
184
185let leaf_inline_element : Comment.leaf_inline_element -> Inline.one = function
186 | `Space -> inline @@ Text " "
187 | `Word s -> inline @@ Text s
188 | `Code_span s -> inline @@ Source (source_of_code s)
189 | `Math_span s -> inline @@ Math s
190 | `Raw_markup (target, s) -> inline @@ Raw_markup (target, s)
191
192let rec non_link_inline_element : Comment.non_link_inline_element -> Inline.one
193 = function
194 | #Comment.leaf_inline_element as e -> leaf_inline_element e
195 | `Styled (style, content) ->
196 inline @@ Styled (style, non_link_inline_element_list content)
197
198and non_link_inline_element_list : _ -> Inline.t =
199 fun elements ->
200 List.map
201 (fun elt -> non_link_inline_element elt.Odoc_model.Location_.value)
202 elements
203
204let link_content = non_link_inline_element_list
205
206let rec inline_element : Comment.inline_element -> Inline.t = function
207 | #Comment.leaf_inline_element as e -> [ leaf_inline_element e ]
208 | `Styled (style, content) ->
209 [ inline @@ Styled (style, inline_element_list content) ]
210 | `Reference (path, content) ->
211 (* TODO Rework that ugly function. *)
212 (* TODO References should be set in code style, if they are to code
213 elements. *)
214 let content =
215 match content with
216 | [] -> None
217 | _ -> Some (non_link_inline_element_list content)
218 (* XXX Span *)
219 in
220 Reference.to_ir ?text:content path
221 | `Link (target, content) ->
222 let content =
223 match content with
224 | [] -> [ inline @@ Text target ]
225 | _ -> non_link_inline_element_list content
226 in
227 [ inline @@ Link { target = External target; content; tooltip = None } ]
228
229and inline_element_list elements =
230 List.concat
231 @@ List.map
232 (fun elt -> inline_element elt.Odoc_model.Location_.value)
233 elements
234
235let module_references ms =
236 let module_reference (m : Comment.module_reference) =
237 let reference =
238 Reference.to_ir (m.module_reference :> Odoc_model.Paths.Reference.t)
239 and synopsis =
240 match m.module_synopsis with
241 | Some synopsis ->
242 [
243 block ~attr:[ "synopsis" ] @@ Inline (inline_element_list synopsis);
244 ]
245 | None -> []
246 in
247 { Description.attr = []; key = reference; definition = synopsis }
248 in
249 let items = List.map module_reference ms in
250 block ~attr:[ "modules" ] @@ Description items
251
252let rec nestable_block_element :
253 Comment.nestable_block_element -> Block.one list =
254 fun content ->
255 match content with
256 | `Paragraph p -> [ paragraph p ]
257 | `Code_block c ->
258 let lang_tag, other_tags =
259 match c.meta with
260 | Some { language = { Odoc_parser.Loc.value; _ }; tags } -> (value, tags)
261 | None -> (default_lang_tag, [])
262 in
263 let prefix = Odoc_extension_registry.prefix_of_language lang_tag in
264 (* Check for a registered code block handler *)
265 let handler_result =
266 match Odoc_extension_registry.find_code_block_handler ~prefix with
267 | Some handler ->
268 let meta = { Odoc_extension_registry.language = lang_tag; tags = other_tags } in
269 handler meta (Odoc_model.Location_.value c.content)
270 | None ->
271 None
272 in
273 (match handler_result with
274 | Some result ->
275 (* Handler produced a result, collect resources/assets and use content *)
276 Resources.add result.resources;
277 Assets.add result.assets;
278 result.content
279 | None ->
280 (* No handler or handler declined, use default rendering *)
281 let rest =
282 match c.output with
283 | Some xs -> nestable_block_element_list xs
284 | None -> []
285 in
286 let value : 'a Odoc_parser.Loc.with_location -> 'a = fun x -> x.value in
287 let classes =
288 List.filter_map
289 (function `Binding (_, _) -> None | `Tag t -> Some (value t))
290 other_tags
291 in
292 let data =
293 List.filter_map
294 (function
295 | `Binding (k, v) -> Some (value k, value v) | `Tag _ -> None)
296 other_tags
297 in
298 [
299 block
300 @@ Source
301 ( lang_tag,
302 classes,
303 data,
304 source_of_code (Odoc_model.Location_.value c.content),
305 rest );
306 ]
307 @ rest)
308 | `Math_block s -> [ block @@ Math s ]
309 | `Verbatim s -> [ block @@ Verbatim s ]
310 | `Modules ms -> [ module_references ms ]
311 | `List (kind, items) ->
312 let kind =
313 match kind with
314 | `Unordered -> Block.Unordered
315 | `Ordered -> Block.Ordered
316 in
317 let f = function
318 | [ { Odoc_model.Location_.value = `Paragraph content; _ } ] ->
319 [ block @@ Block.Inline (inline_element_list content) ]
320 | item -> nestable_block_element_list item
321 in
322 let items = List.map f items in
323 [ block @@ Block.List (kind, items) ]
324 | `Table { data; align } ->
325 let data =
326 List.map
327 (List.map (fun (cell, cell_type) ->
328 (nestable_block_element_list cell, cell_type)))
329 data
330 in
331 let generate_align data =
332 let max (a : int) b = if a < b then b else a in
333 (* Length of the longest line of the table *)
334 let max_length =
335 List.fold_left (fun m l -> max m (List.length l)) 0 data
336 in
337 let rec list_init i =
338 if i <= 0 then [] else Table.Default :: list_init (i - 1)
339 in
340 list_init max_length
341 in
342 let align =
343 match align with
344 | None -> generate_align data
345 | Some align ->
346 List.map
347 (function
348 | None -> Table.Default
349 | Some `Right -> Right
350 | Some `Left -> Left
351 | Some `Center -> Center)
352 align
353 (* We should also check wellness of number of table cells vs alignment,
354 and raise warnings *)
355 in
356 [ block @@ Table { data; align } ]
357 | `Media (href, media, content) ->
358 let content =
359 match (content, href) with
360 | "", `Reference path ->
361 Reference.render_unresolved (path :> Comment.Reference.t)
362 | "", `Link href -> href
363 | _ -> content
364 in
365 let url =
366 match href with
367 | `Reference (`Resolved r) -> (
368 let id =
369 Odoc_model.Paths.Reference.Resolved.Asset.(identifier (r :> t))
370 in
371 match Url.from_asset_identifier id with
372 | url -> Target.Internal (Resolved url))
373 | `Reference _ -> Internal Unresolved
374 | `Link href -> External href
375 in
376 let i =
377 match media with
378 | `Audio -> Block.Audio (url, content)
379 | `Video -> Video (url, content)
380 | `Image -> Image (url, content)
381 in
382 [ block i ]
383
384and paragraph : Comment.paragraph -> Block.one = function
385 | [ { value = `Raw_markup (target, s); _ } ] ->
386 block @@ Block.Raw_markup (target, s)
387 | p -> block @@ Block.Paragraph (inline_element_list p)
388
389and nestable_block_element_list :
390 Comment.nestable_block_element Comment.with_location list -> Block.one list
391 =
392 fun elements ->
393 elements
394 |> List.map Odoc_model.Location_.value
395 |> List.map nestable_block_element
396 |> List.concat
397
398let tag : Comment.tag -> Description.one =
399 fun t ->
400 let sp = inline (Text " ") in
401 let item ?value ~tag definition =
402 let tag_name = inline ~attr:[ "at-tag" ] (Text tag) in
403 let tag_value = match value with None -> [] | Some t -> sp :: t in
404 let key = tag_name :: tag_value in
405 { Description.attr = [ tag ]; key; definition }
406 in
407 let mk_value desc = [ inline ~attr:[ "value" ] desc ] in
408 let text_def s = [ block (Block.Inline [ inline @@ Text s ]) ] in
409 let content_to_inline ?(prefix = []) content =
410 match content with
411 | None -> []
412 | Some content -> prefix @ [ inline @@ Text content ]
413 in
414 match t with
415 | `Author s -> item ~tag:"author" (text_def s)
416 | `Deprecated content ->
417 item ~tag:"deprecated" (nestable_block_element_list content)
418 | `Param (name, content) ->
419 let value = mk_value (Inline.Text name) in
420 item ~tag:"parameter" ~value (nestable_block_element_list content)
421 | `Raise (kind, content) ->
422 let value = inline_element (kind :> Comment.inline_element) in
423 item ~tag:"raises" ~value (nestable_block_element_list content)
424 | `Return content -> item ~tag:"returns" (nestable_block_element_list content)
425 | `See (kind, target, content) ->
426 let value =
427 match kind with
428 | `Url ->
429 mk_value
430 (Inline.Link
431 {
432 target = External target;
433 content = [ inline @@ Text target ];
434 tooltip = None;
435 })
436 | `File -> mk_value (Inline.Source (source_of_code target))
437 | `Document -> mk_value (Inline.Text target)
438 in
439 item ~tag:"see" ~value (nestable_block_element_list content)
440 | `Since s -> item ~tag:"since" (text_def s)
441 | `Before (version, content) ->
442 let value = mk_value (Inline.Text version) in
443 item ~tag:"before" ~value (nestable_block_element_list content)
444 | `Version s -> item ~tag:"version" (text_def s)
445 | `Alert ("deprecated", content) ->
446 let content = content_to_inline content in
447 item ~tag:"deprecated" [ block (Block.Inline content) ]
448 | `Alert (tag, content) ->
449 let content = content_to_inline ~prefix:[ sp ] content in
450 item ~tag:"alert"
451 [ block (Block.Inline ([ inline @@ Text tag ] @ content)) ]
452 | `Custom (name, content) ->
453 (* Check if there's a registered extension for this tag *)
454 let prefix = Odoc_extension_registry.prefix_of_tag name in
455 (match Odoc_extension_registry.find_handler ~prefix with
456 | Some handler ->
457 (match handler name content with
458 | Some result ->
459 (* Extension handled the tag - collect resources/assets and use output *)
460 Resources.add result.Odoc_extension_registry.resources;
461 Assets.add result.Odoc_extension_registry.assets;
462 { Description.attr = [ name ];
463 key = [];
464 definition = result.Odoc_extension_registry.content }
465 | None ->
466 (* Extension declined to handle this tag variant *)
467 item ~tag:name (nestable_block_element_list content))
468 | None ->
469 (* No extension registered - use default handling *)
470 item ~tag:name (nestable_block_element_list content))
471
472let attached_block_element : Comment.attached_block_element -> Block.t =
473 function
474 | #Comment.nestable_block_element as e -> nestable_block_element e
475 | `Tag t ->
476 let t = tag t in
477 if t.Description.key = [] && t.Description.definition = [] then
478 (* Extension tag with no visible output (e.g. config-only tags
479 that only inject resources). Emit nothing. *)
480 []
481 else
482 [ block ~attr:[ "at-tags" ] @@ Description [ t ] ]
483
484(* TODO collaesce tags *)
485
486let block_element : Comment.block_element -> Block.t = function
487 | #Comment.attached_block_element as e -> attached_block_element e
488 | `Heading (_, _, text) ->
489 (* We are not supposed to receive Heading in this context.
490 TODO: Remove heading in attached documentation in the model *)
491 [ block @@ Paragraph (inline_element_list text) ]
492
493let heading_level_to_int = function
494 | `Title -> 0
495 | `Section -> 1
496 | `Subsection -> 2
497 | `Subsubsection -> 3
498 | `Paragraph -> 4
499 | `Subparagraph -> 5
500
501let heading
502 (attrs, { Odoc_model.Paths.Identifier.iv = `Label (_, label); _ }, text) =
503 let label = Odoc_model.Names.LabelName.to_string label in
504 let title = inline_element_list text in
505 let level = heading_level_to_int attrs.Comment.heading_level in
506 let label = Some label in
507 let source_anchor = None in
508 Item.Heading { label; level; title; source_anchor }
509
510let item_element : Comment.block_element -> Item.t list = function
511 | #Comment.attached_block_element as e ->
512 [ Item.Text (attached_block_element e) ]
513 | `Heading h -> [ heading h ]
514
515(** The documentation of the expansion is used if there is no comment attached
516 to the declaration. *)
517let synopsis ~decl_doc ~expansion_doc =
518 let ([], Some docs | docs, _) = (decl_doc, expansion_doc) in
519 match Comment.synopsis docs with Some p -> [ paragraph p ] | None -> []
520
521let standalone docs =
522 List.concat_map item_element
523 @@ List.map (fun x -> x.Odoc_model.Location_.value) docs
524
525let to_ir (docs : Comment.elements) =
526 List.concat_map block_element
527 @@ List.map (fun x -> x.Odoc_model.Location_.value) docs
528
529let has_doc docs = docs <> []