Odoc merge word runs

CHANGES.md

@@ -8,6 +8,11 @@
 - Support for OxCaml modes (@art-w, #1454)
 - Fix OxCaml with-bounds for arbitrary types (@art-w, #1466)
 
+### Performance
+- Memoize doc-comment parsing and skip doc rebuilding during link when nothing needs resolution (@jonludlam, #1480)
+- Store comment text as one node per run of words rather than one per word,
+  which makes `.odoc` and `.odocl` files substantially smaller (@jonludlam, #1487)
+
 ### Fixed
 - Remove requirement for ppx_expect in tests (@jonludlam, #1445)
 - Fix resolving functor through `module type of` (@Leonidas-from-XIV, #1471)

src/document/comment.ml

@@ -148,9 +148,26 @@ module Reference = struct
             [ inline @@ Inline.Link link ])
 end
 
+(* Merged word runs keep the source whitespace, which isn't significant
+   inline, so collapse each run to a single space for rendering. *)
+let collapse_whitespace s =
+  let b = Buffer.create (Stdlib.String.length s) in
+  let in_ws = ref false in
+  Stdlib.String.iter
+    (fun c ->
+      match c with
+      | ' ' | '\t' | '\n' | '\r' ->
+          if not !in_ws then Buffer.add_char b ' ';
+          in_ws := true
+      | c ->
+          Buffer.add_char b c;
+          in_ws := false)
+    s;
+  Buffer.contents b
+
 let leaf_inline_element : Comment.leaf_inline_element -> Inline.one = function
-  | `Space -> inline @@ Text " "
-  | `Word s -> inline @@ Text s
+  | `Space s -> inline @@ Text (collapse_whitespace s)
+  | `Word s -> inline @@ Text (collapse_whitespace s)
   | `Code_span s -> inline @@ Source (source_of_code s)
   | `Math_span s -> inline @@ Math s
   | `Raw_markup (target, s) -> inline @@ Raw_markup (target, s)

src/loader/doc_attr.ml

@@ -150,14 +150,101 @@ let mk_alert_payload ~loc name p =
   let span = read_location loc in
   Location_.at span elt
 
+(* The same doc-comment text is often attached to many definitions (OxCaml's
+   ppx_template can produce tens of thousands of copies of one comment), so
+   parses are memoized by raw text. The parsed AST bakes in absolute source
+   locations, so a cached parse is only reused when it is location-
+   insensitive: it produced no warnings and contains no headings, references
+   or [{!modules ...}], whose locations feed warnings and ambiguous-heading
+   detection during linking. Anything else is re-parsed per occurrence. *)
+
+let rec inline_element_needs_own_location
+    (x : Odoc_parser.Ast.inline_element) =
+  match x with
+  | `Reference _ -> true
+  | `Styled (_, xs) ->
+      List.exists
+        (fun e -> inline_element_needs_own_location (Odoc_parser.Loc.value e))
+        xs
+  | `Space _ | `Word _ | `Code_span _ | `Raw_markup _ | `Link _
+  | `Math_span _ ->
+      false
+
+let rec nestable_block_element_needs_own_location
+    (x : Odoc_parser.Ast.nestable_block_element) =
+  match x with
+  | `Paragraph xs ->
+      List.exists
+        (fun e -> inline_element_needs_own_location (Odoc_parser.Loc.value e))
+        xs
+  | `Modules _ -> true
+  | `Media (_, href, _, _) -> (
+      match Odoc_parser.Loc.value href with
+      | `Reference _ -> true
+      | `Link _ -> false)
+  | `List (_, _, yss) ->
+      List.exists
+        (List.exists (fun e ->
+             nestable_block_element_needs_own_location (Odoc_parser.Loc.value e)))
+        yss
+  | `Table ((grid, _), _) ->
+      List.exists
+        (List.exists (fun (cell, _) ->
+             List.exists
+               (fun e ->
+                 nestable_block_element_needs_own_location
+                   (Odoc_parser.Loc.value e))
+               cell))
+        grid
+  | `Code_block _ | `Verbatim _ | `Math_block _ -> false
+
+let tag_needs_own_location (x : Odoc_parser.Ast.tag) =
+  match x with
+  | `Deprecated c | `Param (_, c) | `Raise (_, c) | `Return c
+  | `See (_, _, c) | `Before (_, c) | `Children_order c | `Toc_status c
+  | `Order_category c | `Short_title c ->
+      List.exists
+        (fun e ->
+          nestable_block_element_needs_own_location (Odoc_parser.Loc.value e))
+        c
+  | `Author _ | `Since _ | `Version _ | `Canonical _ | `Inline | `Open
+  | `Closed | `Hidden ->
+      false
+
+let block_element_needs_own_location (x : Odoc_parser.Ast.block_element) =
+  match x with
+  | `Heading _ -> true
+  | `Tag t -> tag_needs_own_location t
+  | #Odoc_parser.Ast.nestable_block_element as x ->
+      nestable_block_element_needs_own_location x
+
+let ast_needs_own_location (ast : Odoc_parser.Ast.t) =
+  List.exists
+    (fun e -> block_element_needs_own_location (Odoc_parser.Loc.value e))
+    ast
+
+let doc_cache : (string, Odoc_parser.Ast.t) Hashtbl.t = Hashtbl.create 256
+
 let attached ~warnings_tag internal_tags parent attrs =
   let rec loop acc_docs acc_alerts = function
     | attr :: rest -> (
         match parse_attribute attr with
         | Some (`Doc (str, loc)) ->
             let ast_docs =
-              Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
-              |> Error.raise_parser_warnings
+              match Hashtbl.find_opt doc_cache str with
+              | Some cached -> cached
+              | None ->
+                  let parsed =
+                    Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
+                  in
+                  let ast =
+                    Semantics.merge_ast (Error.raise_parser_warnings parsed)
+                  in
+                  (match Odoc_parser.warnings parsed with
+                  | [] when not (ast_needs_own_location ast) ->
+                      Hashtbl.replace doc_cache str ast
+                  | _ -> ());
+                  ast
             in
             loop (List.rev_append ast_docs acc_docs) acc_alerts rest
         | Some (`Alert (name, p, loc)) ->

src/model/comment.ml

@@ -15,7 +15,7 @@ type media = [ `Image | `Audio | `Video ]
 type raw_markup_target = string
 
 type leaf_inline_element =
-  [ `Space
+  [ `Space of string
   | `Word of string
   | `Code_span of string
   | `Math_span of string
@@ -155,7 +155,7 @@ let to_string (l : link_content) =
     | `Code_span s -> s
     | `Word w -> w
     | `Math_span m -> m
-    | `Space -> " "
+    | `Space s -> s
     | `Styled (_, is) -> s_of_is is
     | `Raw_markup (_, r) -> r
   and s_of_is is =

src/model/frontmatter.ml

@@ -77,7 +77,7 @@ let parse_children_order loc (co : tag_payload) =
     | [] -> Ok (Location_.at loc (Children_order (List.rev acc)))
     | ({ Location_.value = `Word word; _ } as w) :: tl ->
         parse_words ({ w with value = parse_child word } :: acc) tl
-    | { Location_.value = `Space; _ } :: tl -> parse_words acc tl
+    | { Location_.value = `Space _; _ } :: tl -> parse_words acc tl
     | { location; _ } :: _ ->
         Error
           (Error.make "Only words are accepted when specifying children order"

src/model/semantics.ml

@@ -128,7 +128,7 @@ let leaf_inline_element :
  fun element ->
   match element with
   | { value = `Word _ | `Code_span _ | `Math_span _; _ } as element -> element
-  | { value = `Space _; _ } -> Location.same element `Space
+  | { value = `Space s; _ } -> Location.same element (`Space s)
   | { value = `Raw_markup (target, s); location } -> (
       match target with
       | Some invalid_target
@@ -145,6 +145,97 @@ let leaf_inline_element :
           Location.same element (`Code_span s)
       | Some target -> Location.same element (`Raw_markup (target, s)))
 
+(* Rebuild [elt] only if the merge changed something *)
+let same elt content content' mk =
+  if content' == content then elt
+  else { elt with Location_.value = mk content' }
+
+(* Merge runs of [`Word]/[`Space] into one [`Word] *)
+let rec merge_ast_inline_elements elements =
+  let flush run acc =
+    match run with
+    | [] -> acc
+    | [ single ] -> single :: acc
+    | _ ->
+        let text_of { Location_.value; _ } =
+          match value with `Word w -> w | `Space s -> s | _ -> assert false
+        in
+        let value = `Word (String.concat ~sep:"" (List.rev_map text_of run)) in
+        let location =
+          Location.span (List.rev_map (fun e -> e.Location_.location) run)
+        in
+        { Location_.value; location } :: acc
+  in
+  let rec loop run acc = function
+    | [] -> List.rev (flush run acc)
+    | ({ Location_.value = `Word _ | `Space _; _ } as elt) :: tl ->
+        loop (elt :: run) acc tl
+    | elt :: tl -> loop [] (merge_ast_inline_element elt :: flush run acc) tl
+  in
+  let merged = loop [] [] elements in
+  let unchanged =
+    try List.for_all2 ( == ) merged elements with Invalid_argument _ -> false
+  in
+  if unchanged then elements else merged
+
+and merge_ast_inline_element elt =
+  let same content mk =
+    same elt content (merge_ast_inline_elements content) mk
+  in
+  match elt.Location_.value with
+  | `Styled (style, content) -> same content (fun c -> `Styled (style, c))
+  | `Reference (kind, target, content) ->
+      same content (fun c -> `Reference (kind, target, c))
+  | `Link (target, content) -> same content (fun c -> `Link (target, c))
+  | _ -> elt
+
+let rec merge_ast_nestable elt =
+  match elt.Location_.value with
+  | `Paragraph content ->
+      same elt content (merge_ast_inline_elements content) (fun c ->
+          `Paragraph c)
+  | `List (kind, weight, items) ->
+      let items = List.map (List.map merge_ast_nestable) items in
+      { elt with Location_.value = `List (kind, weight, items) }
+  | `Table ((grid, align), weight) ->
+      let grid =
+        List.map
+          (List.map (fun (cell, kind) ->
+               (List.map merge_ast_nestable cell, kind)))
+          grid
+      in
+      { elt with Location_.value = `Table ((grid, align), weight) }
+  | `Code_block _ | `Verbatim _ | `Modules _ | `Math_block _ | `Media _ -> elt
+
+(* Internal tags are skipped: they parse their payload word by word. *)
+let merge_ast (ast : Ast.t) : Ast.t =
+  let nestables = List.map merge_ast_nestable in
+  let tag : Ast.tag -> Ast.tag = function
+    | `Deprecated content -> `Deprecated (nestables content)
+    | `Param (s, content) -> `Param (s, nestables content)
+    | `Raise (s, content) -> `Raise (s, nestables content)
+    | `Return content -> `Return (nestables content)
+    | `See (kind, s, content) -> `See (kind, s, nestables content)
+    | `Before (s, content) -> `Before (s, nestables content)
+    | (`Author _ | `Since _ | `Version _ | #Ast.internal_tag) as t -> t
+  in
+  List.map
+    (fun elt ->
+      match elt.Location_.value with
+      | `Heading (level, label, content) ->
+          same elt content (merge_ast_inline_elements content) (fun c ->
+              `Heading (level, label, c))
+      | `Tag t -> { elt with Location_.value = `Tag (tag t) }
+      | #Ast.nestable_block_element as v ->
+          let nested = merge_ast_nestable { elt with Location_.value = v } in
+          if nested.Location_.value == v then elt
+          else
+            {
+              elt with
+              Location_.value = (nested.Location_.value :> Ast.block_element);
+            })
+    ast
+
 type surrounding =
   [ `Link of
     string * Odoc_parser.Ast.inline_element Location_.with_location list
@@ -352,6 +443,23 @@ let generate_heading_label : Comment.inline_element with_location list -> string
            Bytes.set result index c);
     Bytes.unsafe_to_string result
   in
+  (* Whitespace runs inside a merged [`Word] stood for a single [`Space], so
+     become a single hyphen. Code spans keep the per-character version. *)
+  let hyphenate_word_runs s =
+    let b = Buffer.create (String.length s) in
+    let in_ws = ref false in
+    Stdlib.String.iter
+      (fun c ->
+        match c with
+        | ' ' | '\t' | '\r' | '\n' ->
+            if not !in_ws then Buffer.add_char b '-';
+            in_ws := true
+        | c ->
+            Buffer.add_char b (Astring.Char.Ascii.lowercase c);
+            in_ws := false)
+      s;
+    Buffer.contents b
+  in
 
   let strip_locs li = List.map (fun ele -> ele.Location.value) li in
   (* Perhaps this should be done using a [Buffer.t]; we can switch to that as
@@ -361,8 +469,8 @@ let generate_heading_label : Comment.inline_element with_location list -> string
     | element :: more ->
         let anchor =
           match (element : Comment.inline_element) with
-          | `Space -> anchor ^ "-"
-          | `Word w -> anchor ^ Astring.String.Ascii.lowercase w
+          | `Space _ -> anchor ^ "-"
+          | `Word w -> anchor ^ hyphenate_word_runs w
           | `Code_span c | `Math_span c ->
               anchor ^ replace_spaces_with_hyphens_and_lowercase c
           | `Raw_markup _ ->
@@ -576,7 +684,7 @@ let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function
       in
       let lines =
         let do_ parse loc els =
-          let els = nestable_block_elements els in
+          let els = List.map nestable_block_element els in
           match parse loc els with
           | Ok res -> Some res
           | Error e ->
@@ -603,7 +711,7 @@ let ast_to_comment ~internal_tags ~tags_allowed ~parent_of_sections
     (ast : Ast.t) alerts =
   Error.catch_warnings (fun () ->
       let status = { tags_allowed; parent_of_sections } in
-      let ast, tags = strip_internal_tags ast in
+      let ast, tags = strip_internal_tags (merge_ast ast) in
       let elts =
         top_level_block_elements status ast |> append_alerts_to_comment alerts
       in

src/model/semantics.mli

@@ -11,6 +11,11 @@ type sections_allowed = [ `All | `No_titles | `None ]
 type alerts =
   [ `Tag of [ `Alert of string * string option ] ] Location_.with_location list
 
+val merge_ast : Odoc_parser.Ast.t -> Odoc_parser.Ast.t
+(** Merge runs of [`Word]/[`Space] into single [`Word]s. Idempotent; the loader
+    applies it before its parse cache so that repeated comments share the merged
+    nodes. *)
+
 val ast_to_comment :
   internal_tags:'tags handle_internal_tags ->
   tags_allowed:bool ->

src/model_desc/comment_desc.ml

@@ -6,7 +6,7 @@ open Paths_desc
 let ignore_loc x = x.Location_.value
 
 type general_inline_element =
-  [ `Space
+  [ `Space of string
   | `Word of string
   | `Code_span of string
   | `Math_span of string
@@ -72,7 +72,7 @@ let rec inline_element : general_inline_element t =
   in
   Variant
     (function
-    | `Space -> C0 "`Space"
+    | `Space s -> C ("`Space", s, string)
     | `Word x -> C ("`Word", x, string)
     | `Code_span x -> C ("`Code_span", x, string)
     | `Math_span x -> C ("`Math_span", x, string)

src/odoc/odoc_link.ml

@@ -27,11 +27,11 @@ let content_for_hidden_modules =
   let sentence =
     [
       `Word "This";
-      `Space;
+      `Space " ";
       `Word "module";
-      `Space;
+      `Space " ";
       `Word "is";
-      `Space;
+      `Space " ";
       `Word "hidden.";
     ]
   in

src/search/text.ml

@@ -72,7 +72,7 @@ module Of_comments = struct
     | `Code_span s -> s
     | `Word w -> w
     | `Math_span m -> m
-    | `Space -> " "
+    | `Space s -> s
     | `Reference (_, c) -> link_content c
     | `Link (_, c) -> link_content c
     | `Styled (_, b) -> inlines b