jon.recoil.org
this repo has no description
1open Odoc_utils
2
3module Location = Location_
4module Ast = Odoc_parser.Ast
5
6type internal_tags_removed =
7 [ `Tag of Ast.ocamldoc_tag
8 | `Heading of Ast.heading
9 | `Media of
10 Ast.reference_kind * Ast.media_href Ast.with_location * string * Ast.media
11 | Ast.nestable_block_element ]
12(** {!Ast.block_element} without internal tags. *)
13
14type _ handle_internal_tags =
15 | Expect_status :
16 [ `Default | `Inline | `Open | `Closed ] handle_internal_tags
17 | Expect_canonical : Reference.path option handle_internal_tags
18 | Expect_none : unit handle_internal_tags
19 | Expect_page_tags : Frontmatter.t handle_internal_tags
20
21let describe_internal_tag = function
22 | `Canonical _ -> "@canonical"
23 | `Inline -> "@inline"
24 | `Open -> "@open"
25 | `Closed -> "@closed"
26 | `Hidden -> "@hidden"
27 | `Children_order _ -> "@children_order"
28 | `Toc_status _ -> "@toc_status"
29 | `Short_title _ -> "@short_title"
30 | `Order_category _ -> "@order_category"
31
32let warn_unexpected_tag { Location.value; location } =
33 Error.raise_warning
34 @@ Error.make "Unexpected tag '%s' at this location."
35 (describe_internal_tag value)
36 location
37
38let warn_root_canonical location =
39 Error.raise_warning
40 @@ Error.make "Canonical paths must contain a dot, eg. X.Y." location
41
42let rec find_tag ~filter = function
43 | [] -> None
44 | hd :: tl -> (
45 match filter hd.Location.value with
46 | Some x -> Some (x, hd.location)
47 | None ->
48 warn_unexpected_tag hd;
49 find_tag ~filter tl)
50
51let rec find_tags acc ~filter = function
52 | [] -> List.rev acc
53 | hd :: tl -> (
54 match filter hd.Location.value with
55 | Some x -> find_tags ((x, hd.location) :: acc) ~filter tl
56 | None ->
57 warn_unexpected_tag hd;
58 find_tags acc ~filter tl)
59
60(* Errors *)
61let invalid_raw_markup_target : string -> Location.span -> Error.t =
62 Error.make ~suggestion:"try '{%html:...%}'."
63 "'{%%%s:': bad raw markup target."
64
65let default_raw_markup_target_not_supported : Location.span -> Error.t =
66 Error.make ~suggestion:"try '{%html:...%}'."
67 "'{%%...%%}' (raw markup) needs a target language."
68
69let bad_heading_level : int -> Location.span -> Error.t =
70 Error.make "'%d': bad heading level (0-5 allowed)."
71
72let heading_level_should_be_lower_than_top_level :
73 int -> int -> Location.span -> Error.t =
74 fun this_heading_level top_heading_level ->
75 Error.make "%s: heading level should be lower than top heading level '%d'."
76 (Printf.sprintf "'{%i'" this_heading_level)
77 top_heading_level
78
79let page_heading_required : string -> Error.t =
80 Error.filename_only "Pages (.mld files) should start with a heading."
81
82let tags_not_allowed : Location.span -> Error.t =
83 Error.make "Tags are not allowed in pages."
84
85let not_allowed :
86 ?suggestion:string ->
87 what:string ->
88 in_what:string ->
89 Location.span ->
90 Error.t =
91 fun ?suggestion ~what ~in_what ->
92 Error.make ?suggestion "%s is not allowed in %s."
93 (Astring.String.Ascii.capitalize what)
94 in_what
95
96let describe_element = function
97 | `Reference (`Simple, _, _) -> "'{!...}' (cross-reference)"
98 | `Reference (`With_text, _, _) -> "'{{!...} ...}' (cross-reference)"
99 | `Link (_, _) -> "'{{:...} ...}' (external link)"
100 | `Heading (level, _, _) ->
101 Printf.sprintf "'{%i ...}' (section heading)" level
102 | `Specific s -> s
103
104(* End of errors *)
105
106type 'a with_location = 'a Location.with_location
107
108type ast_leaf_inline_element =
109 [ `Space of string
110 | `Word of string
111 | `Code_span of string
112 | `Math_span of string
113 | `Raw_markup of string option * string ]
114
115type sections_allowed = [ `All | `No_titles | `None ]
116
117type alerts =
118 [ `Tag of [ `Alert of string * string option ] ] Location_.with_location list
119
120type status = {
121 tags_allowed : bool;
122 parent_of_sections : Paths.Identifier.LabelParent.t;
123}
124
125let leaf_inline_element :
126 ast_leaf_inline_element with_location ->
127 Comment.leaf_inline_element with_location =
128 fun element ->
129 match element with
130 | { value = `Word _ | `Code_span _ | `Math_span _; _ } as element -> element
131 | { value = `Space _; _ } -> Location.same element `Space
132 | { value = `Raw_markup (target, s); location } -> (
133 match target with
134 | Some invalid_target
135 when String.trim invalid_target = ""
136 || String.exists
137 (function '%' | '}' -> true | _ -> false)
138 invalid_target ->
139 Error.raise_warning
140 (invalid_raw_markup_target invalid_target location);
141
142 Location.same element (`Code_span s)
143 | None ->
144 Error.raise_warning (default_raw_markup_target_not_supported location);
145 Location.same element (`Code_span s)
146 | Some target -> Location.same element (`Raw_markup (target, s)))
147
148type surrounding =
149 [ `Link of
150 string * Odoc_parser.Ast.inline_element Location_.with_location list
151 | `Reference of
152 [ `Simple | `With_text ]
153 * string Location_.with_location
154 * Odoc_parser.Ast.inline_element Location_.with_location list
155 | `Specific of string ]
156
157let rec non_link_inline_element :
158 surrounding:surrounding ->
159 Odoc_parser.Ast.inline_element with_location ->
160 Comment.non_link_inline_element with_location =
161 fun ~surrounding element ->
162 match element with
163 | { value = #ast_leaf_inline_element; _ } as element ->
164 (leaf_inline_element element
165 :> Comment.non_link_inline_element with_location)
166 | { value = `Styled (style, content); _ } ->
167 `Styled (style, non_link_inline_elements ~surrounding content)
168 |> Location.same element
169 | ( { value = `Reference (_, _, content); _ }
170 | { value = `Link (_, content); _ } ) as element ->
171 not_allowed
172 ~what:(describe_element element.value)
173 ~in_what:(describe_element surrounding)
174 element.location
175 |> Error.raise_warning;
176
177 `Styled (`Emphasis, non_link_inline_elements ~surrounding content)
178 |> Location.same element
179
180and non_link_inline_elements ~surrounding elements =
181 List.map (non_link_inline_element ~surrounding) elements
182
183let rec inline_element :
184 Odoc_parser.Ast.inline_element with_location ->
185 Comment.inline_element with_location =
186 fun element ->
187 match element with
188 | { value = #ast_leaf_inline_element; _ } as element ->
189 (leaf_inline_element element :> Comment.inline_element with_location)
190 | { value = `Styled (style, content); location } ->
191 `Styled (style, inline_elements content) |> Location.at location
192 | { value = `Reference (kind, target, content) as value; location } -> (
193 let { Location.value = target; location = target_location } = target in
194 match Error.raise_warnings (Reference.parse target_location target) with
195 | Ok target ->
196 let content = non_link_inline_elements ~surrounding:value content in
197 Location.at location (`Reference (target, content))
198 | Error error ->
199 Error.raise_warning error;
200 let placeholder =
201 match kind with
202 | `Simple -> `Code_span target
203 | `With_text -> `Styled (`Emphasis, content)
204 in
205 inline_element (Location.at location placeholder))
206 | { value = `Link (target, content) as value; location } ->
207 `Link (target, non_link_inline_elements ~surrounding:value content)
208 |> Location.at location
209
210and inline_elements elements = List.map inline_element elements
211
212let rec nestable_block_element :
213 Odoc_parser.Ast.nestable_block_element with_location ->
214 Comment.nestable_block_element with_location =
215 fun element ->
216 match element with
217 | { value = `Paragraph content; location } ->
218 Location.at location (`Paragraph (inline_elements content))
219 | { value = `Code_block { meta; delimiter; content; output }; location } ->
220 let output =
221 match output with
222 | None -> None
223 | Some l -> Some (List.map nestable_block_element l)
224 in
225 let trimmed_content, warnings =
226 Odoc_parser.codeblock_content location content.value
227 in
228 let warnings = List.map Error.t_of_parser_t warnings in
229 List.iter (Error.raise_warning ~non_fatal:true) warnings;
230 let content = Location.at content.location trimmed_content in
231 let code_block = { Comment.meta; delimiter; content; output } in
232 Location.at location (`Code_block code_block)
233 | { value = `Math_block s; location } -> Location.at location (`Math_block s)
234 | { value = `Verbatim v; location } ->
235 let v, warnings = Odoc_parser.codeblock_content location v in
236 let warnings = List.map Error.t_of_parser_t warnings in
237 List.iter (Error.raise_warning ~non_fatal:true) warnings;
238 Location.at location (`Verbatim v)
239 | { value = `Modules modules; location } ->
240 let modules =
241 List.fold_left
242 (fun acc { Location.value; location } ->
243 match
244 Error.raise_warnings (Reference.read_mod_longident location value)
245 with
246 | Ok r ->
247 { Comment.module_reference = r; module_synopsis = None } :: acc
248 | Error error ->
249 Error.raise_warning error;
250 acc)
251 [] modules
252 |> List.rev
253 in
254 Location.at location (`Modules modules)
255 | { value = `List (kind, _syntax, items); location } ->
256 `List (kind, List.map nestable_block_elements items)
257 |> Location.at location
258 | { value = `Table ((grid, align), (`Heavy | `Light)); location } ->
259 let data =
260 List.map
261 (List.map (fun (cell, cell_type) ->
262 (nestable_block_elements cell, cell_type)))
263 grid
264 in
265 `Table { Comment.data; align } |> Location.at location
266 | { value = `Media (_, { value = `Link href; _ }, content, m); location } ->
267 `Media (`Link href, m, content) |> Location.at location
268 | {
269 value =
270 `Media
271 (kind, { value = `Reference href; location = href_location }, content, m);
272 location;
273 } -> (
274 let fallback error =
275 Error.raise_warning error;
276 let placeholder =
277 match kind with
278 | `Simple -> `Code_span href
279 | `With_text ->
280 `Styled (`Emphasis, [ `Word content |> Location.at location ])
281 in
282 `Paragraph (inline_elements [ placeholder |> Location.at location ])
283 |> Location.at location
284 in
285 match Error.raise_warnings (Reference.parse_asset href_location href) with
286 | Ok target ->
287 `Media (`Reference target, m, content) |> Location.at location
288 | Error error -> fallback error)
289
290and nestable_block_elements elements = List.map nestable_block_element elements
291
292let tag :
293 location:Location.span ->
294 status ->
295 Ast.ocamldoc_tag ->
296 ( Comment.block_element with_location,
297 internal_tags_removed with_location )
298 result =
299 fun ~location status tag ->
300 if not status.tags_allowed then
301 (* Trigger a warning but do not remove the tag. Avoid turning tags into
302 text that would render the same. *)
303 Error.raise_warning (tags_not_allowed location);
304 let ok t = Ok (Location.at location (`Tag t)) in
305 match tag with
306 | (`Author _ | `Since _ | `Version _) as tag -> ok tag
307 | `Custom (name, content) ->
308 ok (`Custom (name, nestable_block_elements content))
309 | `Deprecated content -> ok (`Deprecated (nestable_block_elements content))
310 | `Param (name, content) ->
311 ok (`Param (name, nestable_block_elements content))
312 | `Raise (name, content) -> (
313 match Error.raise_warnings (Reference.parse location name) with
314 (* TODO: location for just name *)
315 | Ok target ->
316 ok (`Raise (`Reference (target, []), nestable_block_elements content))
317 | Error error ->
318 Error.raise_warning error;
319 let placeholder = `Code_span name in
320 ok (`Raise (placeholder, nestable_block_elements content)))
321 | `Return content -> ok (`Return (nestable_block_elements content))
322 | `See (kind, target, content) ->
323 ok (`See (kind, target, nestable_block_elements content))
324 | `Before (version, content) ->
325 ok (`Before (version, nestable_block_elements content))
326
327(* When the user does not give a section heading a label (anchor), we generate
328 one from the text in the heading. This is the common case. This involves
329 simply scanning the AST for words, lowercasing them, and joining them with
330 hyphens.
331
332 This must be done in the parser (i.e. early, not at HTML/other output
333 generation time), so that the cross-referencer can see these anchors. *)
334let generate_heading_label : Comment.inline_element with_location list -> string
335 =
336 fun content ->
337 (* Code spans can contain spaces, so we need to replace them with hyphens. We
338 also lowercase all the letters, for consistency with the rest of this
339 procedure. *)
340 let replace_spaces_with_hyphens_and_lowercase s =
341 let result = Bytes.create (String.length s) in
342 s
343 |> String.iteri (fun index c ->
344 let c =
345 match c with
346 | ' ' | '\t' | '\r' | '\n' -> '-'
347 | _ -> Astring.Char.Ascii.lowercase c
348 in
349 Bytes.set result index c);
350 Bytes.unsafe_to_string result
351 in
352
353 let strip_locs li = List.map (fun ele -> ele.Location.value) li in
354 (* Perhaps this should be done using a [Buffer.t]; we can switch to that as
355 needed. *)
356 let rec scan_inline_elements anchor = function
357 | [] -> anchor
358 | element :: more ->
359 let anchor =
360 match (element : Comment.inline_element) with
361 | `Space -> anchor ^ "-"
362 | `Word w -> anchor ^ Astring.String.Ascii.lowercase w
363 | `Code_span c | `Math_span c ->
364 anchor ^ replace_spaces_with_hyphens_and_lowercase c
365 | `Raw_markup _ ->
366 (* TODO Perhaps having raw markup in a section heading should be an
367 error? *)
368 anchor
369 | `Styled (_, content) ->
370 content |> strip_locs |> scan_inline_elements anchor
371 | `Reference (_, content) | `Link (_, content) ->
372 content |> strip_locs
373 |> List.map (fun (ele : Comment.non_link_inline_element) ->
374 (ele :> Comment.inline_element))
375 |> scan_inline_elements anchor
376 in
377 scan_inline_elements anchor more
378 in
379 content |> List.map (fun ele -> ele.Location.value) |> scan_inline_elements ""
380
381let section_heading :
382 status ->
383 top_heading_level:int option ->
384 Location.span ->
385 [ `Heading of _ ] ->
386 int option * Comment.block_element with_location =
387 fun status ~top_heading_level location heading ->
388 let (`Heading (level, label, content)) = heading in
389
390 let text = inline_elements content in
391
392 let heading_label_explicit, label =
393 match label with
394 | Some label -> (true, label)
395 | None -> (false, generate_heading_label text)
396 in
397 let label =
398 Paths.Identifier.Mk.label
399 (status.parent_of_sections, Names.LabelName.make_std label)
400 in
401
402 let mk_heading heading_level =
403 let attrs = { Comment.heading_level; heading_label_explicit } in
404 let element = Location.at location (`Heading (attrs, label, text)) in
405 let top_heading_level =
406 match top_heading_level with None -> Some level | some -> some
407 in
408 (top_heading_level, element)
409 in
410 let level' =
411 match level with
412 | 0 -> `Title
413 | 1 -> `Section
414 | 2 -> `Subsection
415 | 3 -> `Subsubsection
416 | 4 -> `Paragraph
417 | 5 -> `Subparagraph
418 | _ ->
419 Error.raise_warning (bad_heading_level level location);
420 (* Implicitly promote to level-5. *)
421 `Subparagraph
422 in
423 let () =
424 match top_heading_level with
425 | Some top_level when level <= top_level && level <= 5 ->
426 Error.raise_warning
427 (heading_level_should_be_lower_than_top_level level top_level location)
428 | _ -> ()
429 in
430 mk_heading level'
431
432let validate_first_page_heading status ast_element =
433 match status.parent_of_sections.iv with
434 | `Page (_, name) | `LeafPage (_, name) -> (
435 match ast_element with
436 | { Location.value = `Heading (_, _, _); _ } -> ()
437 | _invalid_ast_element ->
438 let filename = Names.PageName.to_string name ^ ".mld" in
439 Error.raise_warning (page_heading_required filename))
440 | _not_a_page -> ()
441
442let top_level_block_elements status ast_elements =
443 let rec traverse :
444 top_heading_level:int option ->
445 Comment.block_element with_location list ->
446 internal_tags_removed with_location list ->
447 Comment.block_element with_location list =
448 fun ~top_heading_level comment_elements_acc ast_elements ->
449 match ast_elements with
450 | [] -> List.rev comment_elements_acc
451 | ast_element :: ast_elements -> (
452 (* The first [ast_element] in pages must be a title or section heading. *)
453 if top_heading_level = None then
454 validate_first_page_heading status ast_element;
455
456 match ast_element with
457 | { value = #Odoc_parser.Ast.nestable_block_element; _ } as element ->
458 let element = nestable_block_element element in
459 let element = (element :> Comment.block_element with_location) in
460 traverse ~top_heading_level
461 (element :: comment_elements_acc)
462 ast_elements
463 | { value = `Tag the_tag; location } -> (
464 match tag ~location status the_tag with
465 | Ok element ->
466 traverse ~top_heading_level
467 (element :: comment_elements_acc)
468 ast_elements
469 | Error placeholder ->
470 traverse ~top_heading_level comment_elements_acc
471 (placeholder :: ast_elements))
472 | { value = `Heading _ as heading; _ } ->
473 let top_heading_level, element =
474 section_heading status ~top_heading_level
475 ast_element.Location.location heading
476 in
477 traverse ~top_heading_level
478 (element :: comment_elements_acc)
479 ast_elements)
480 in
481 let top_heading_level =
482 (* Non-page documents have a generated title. *)
483 match status.parent_of_sections.iv with
484 | `Page _ | `LeafPage _ -> None
485 | _parent_with_generated_title -> Some 0
486 in
487 traverse ~top_heading_level [] ast_elements
488
489let strip_internal_tags ast : internal_tags_removed with_location list * _ =
490 let rec loop ~start tags ast' = function
491 | ({ Location.value = `Tag (#Ast.internal_tag as tag); _ } as wloc) :: tl
492 -> (
493 let next tag =
494 loop ~start ({ wloc with value = tag } :: tags) ast' tl
495 in
496 match tag with
497 | (`Inline | `Open | `Closed | `Hidden) as tag -> next tag
498 | ( `Children_order _ | `Short_title _ | `Toc_status _
499 | `Order_category _ ) as tag ->
500 let tag_name = describe_internal_tag tag in
501 if not start then
502 Error.raise_warning
503 (Error.make "%s tag has to be before any content" tag_name
504 wloc.location);
505 next tag
506 | `Canonical { Location.value = s; location = r_location } -> (
507 match
508 Error.raise_warnings (Reference.read_path_longident r_location s)
509 with
510 | Ok path -> next (`Canonical path)
511 | Error e ->
512 Error.raise_warning e;
513 loop ~start tags ast' tl))
514 | ({
515 value =
516 ( `Tag #Ast.ocamldoc_tag
517 | `Heading _ | `Media _
518 | #Ast.nestable_block_element );
519 _;
520 } as hd)
521 :: tl ->
522 loop ~start:false tags (hd :: ast') tl
523 | [] -> (List.rev ast', List.rev tags)
524 in
525 loop ~start:true [] [] ast
526
527(** Append alerts at the end of the comment. Tags are favoured in case of alerts
528 of the same name. *)
529let append_alerts_to_comment alerts
530 (comment : Comment.block_element with_location list) =
531 let alerts =
532 List.filter
533 (fun alert ->
534 let (`Tag alert) = alert.Location_.value in
535 List.for_all
536 (fun elem ->
537 match (elem.Location_.value, alert) with
538 | `Tag (`Deprecated _), `Alert ("deprecated", _) -> false
539 | _ -> true)
540 comment)
541 alerts
542 in
543 comment @ (alerts :> Comment.elements)
544
545let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function
546 | Expect_status -> (
547 match
548 find_tag
549 ~filter:(function
550 | (`Inline | `Open | `Closed) as t -> Some t | _ -> None)
551 tags
552 with
553 | Some (status, _) -> status
554 | None -> `Default)
555 | Expect_canonical -> (
556 match
557 find_tag ~filter:(function `Canonical p -> Some p | _ -> None) tags
558 with
559 | Some (`Root _, location) ->
560 warn_root_canonical location;
561 None
562 | Some ((`Dot _ as p), _) -> Some p
563 | None -> None)
564 | Expect_page_tags ->
565 let unparsed_lines =
566 find_tags []
567 ~filter:(function
568 | ( `Children_order _ | `Toc_status _ | `Short_title _
569 | `Order_category _ ) as p ->
570 Some p
571 | _ -> None)
572 tags
573 in
574 let lines =
575 let do_ parse loc els =
576 let els = nestable_block_elements els in
577 match parse loc els with
578 | Ok res -> Some res
579 | Error e ->
580 Error.raise_warning e;
581 None
582 in
583 List.filter_map
584 (function
585 | `Children_order co, loc ->
586 do_ Frontmatter.parse_children_order loc co
587 | `Toc_status co, loc -> do_ Frontmatter.parse_toc_status loc co
588 | `Short_title t, loc -> do_ Frontmatter.parse_short_title loc t
589 | `Order_category t, loc ->
590 do_ Frontmatter.parse_order_category loc t)
591 unparsed_lines
592 in
593 Frontmatter.of_lines lines |> Error.raise_warnings
594 | Expect_none ->
595 (* Will raise warnings. *)
596 ignore (find_tag ~filter:(fun _ -> None) tags);
597 ()
598
599let ast_to_comment ~internal_tags ~tags_allowed ~parent_of_sections
600 (ast : Ast.t) alerts =
601 Error.catch_warnings (fun () ->
602 let status = { tags_allowed; parent_of_sections } in
603 let ast, tags = strip_internal_tags ast in
604 let elts =
605 top_level_block_elements status ast |> append_alerts_to_comment alerts
606 in
607 (elts, handle_internal_tags tags internal_tags))
608
609let parse_comment ~internal_tags ~tags_allowed ~containing_definition ~location
610 ~text =
611 Error.catch_warnings (fun () ->
612 let ast =
613 Odoc_parser.parse_comment ~location ~text |> Error.raise_parser_warnings
614 in
615 ast_to_comment ~internal_tags ~tags_allowed
616 ~parent_of_sections:containing_definition ast []
617 |> Error.raise_warnings)
618
619let parse_reference text =
620 let location =
621 Location_.
622 {
623 file = "";
624 start = { line = 0; column = 0 };
625 end_ = { line = 0; column = String.length text };
626 }
627 in
628 Reference.parse location text
629
630let non_link_inline_element :
631 context:string ->
632 Odoc_parser.Ast.inline_element with_location list ->
633 Comment.non_link_inline_element with_location list =
634 fun ~context elements ->
635 let surrounding = `Specific context in
636 non_link_inline_elements ~surrounding elements