Fix stack overflow when highlighting large source files

CHANGES.md

@@ -79,6 +79,7 @@
 - Fix bug where source rendering would cause odoc to fail completely if it
   encounters invalid syntax (@jonludlam #1208)
 - Add missing parentheses in 'val (let*) : ...' (@Julow, #1268)
+- Fix syntax highlighting not working for very large files (@jonludlam, @Julow, #1277)
 
 # 2.4.4
 

src/document/generator.ml

@@ -290,7 +290,8 @@ module Make (Syntax : SYNTAX) = struct
       in
       let infos = Odoc_utils.List.filter_map mapper infos in
       let syntax_info =
-        List.map (fun (ty, loc) -> (Source_page.Syntax ty, loc)) syntax_info
+        List.rev_map (fun (ty, loc) -> (Source_page.Syntax ty, loc)) syntax_info
+        |> List.rev
       in
       let contents = Impl.impl ~infos:(infos @ syntax_info) source_code in
       { Source_page.url; contents }

src/driver/run.ml

@@ -15,6 +15,7 @@ type t = {
   output_file : Fpath.t option;
   output : string;
   errors : string;
+  status : [ `Exited of int | `Signaled of int ];
 }
 
 (* Environment variables passed to commands. *)
@@ -43,7 +44,7 @@ let run env cmd output_file =
     |> Array.of_list
   in
   (* Logs.debug (fun m -> m "Running cmd %a" Fmt.(list ~sep:sp string) cmd); *)
-  let output, errors =
+  let output, errors, status =
     Eio.Switch.run ~name:"Process.parse_out" @@ fun sw ->
     let r, w = Eio.Process.pipe proc_mgr ~sw in
     let re, we = Eio.Process.pipe proc_mgr ~sw in
@@ -62,18 +63,8 @@ let run env cmd output_file =
       in
       Eio.Flow.close r;
       Eio.Flow.close re;
-      match Eio.Process.await child with
-      | `Exited 0 -> (output, err)
-      | `Exited n ->
-          Logs.err (fun m -> m "%d - Process exitted %d: stderr=%s" myn n err);
-          failwith "Error"
-      | `Signaled n ->
-          let err =
-            Format.sprintf "Error from %s\n%d - Signalled %d: stderr=%s"
-              (String.concat " " cmd) myn n err
-          in
-          Logs.err (fun m -> m "%s" err);
-          failwith err
+      let status = Eio.Process.await child in
+      (output, err, status)
     with Eio.Exn.Io _ as ex ->
       let bt = Printexc.get_raw_backtrace () in
       Eio.Exn.reraise_with_context ex bt "%d - running command: %a" myn
@@ -83,8 +74,26 @@ let run env cmd output_file =
       m "Finished running cmd %a" Fmt.(list ~sep:sp string) cmd); *)
   let t_end = Unix.gettimeofday () in
   let time = t_end -. t_start in
-  let result = { cmd; time; output_file; output; errors } in
+  let result = { cmd; time; output_file; output; errors; status } in
   commands := result :: !commands;
+  (match result.status with
+  | `Exited 0 -> ()
+  | _ ->
+      let verb, n =
+        match result.status with
+        | `Exited n -> ("exited", n)
+        | `Signaled n -> ("signaled", n)
+      in
+      Logs.err (fun m ->
+          m
+            "@[<2>Process %s with %d:@ '@[%a'@]@]@\n\n\
+             Stdout:\n\
+             %s\n\n\
+             Stderr:\n\
+             %s"
+            verb n
+            Fmt.(list ~sep:sp string)
+            result.cmd result.output result.errors));
   result
 
 (** Print an executed command and its time. *)

src/driver/worker_pool.ml

@@ -16,15 +16,20 @@ let stream : t = Eio.Stream.create 0
 
 let handle_job env request output_file = Run.run env request output_file
 
+exception Worker_failure of Run.t
+
 let rec run_worker env id : unit =
   let { request; output_file; description }, reply = Eio.Stream.take stream in
   Atomic.incr Stats.stats.processes;
   Atomic.set Stats.stats.process_activity.(id) description;
   (try
      let result = handle_job env request output_file in
-     Atomic.decr Stats.stats.processes;
-     Atomic.set Stats.stats.process_activity.(id) "idle";
-     Promise.resolve reply (Ok result)
+     match result.status with
+     | `Exited 0 ->
+         Atomic.decr Stats.stats.processes;
+         Atomic.set Stats.stats.process_activity.(id) "idle";
+         Promise.resolve reply (Ok result)
+     | _ -> Promise.resolve_error reply (Worker_failure result)
    with e -> Promise.resolve_error reply e);
   run_worker env id
 

src/html/generator.ml

@@ -86,7 +86,7 @@ and source k ?a (t : Source.t) =
         let content = tokens l in
         if content = [] then [] else [ Html.span content ]
     | Tag (Some s, l) -> [ Html.span ~a:[ Html.a_class [ s ] ] (tokens l) ]
-  and tokens t = Odoc_utils.List.concat_map t ~f:token in
+  and tokens t = List.concat_map token t in
   match tokens t with [] -> [] | l -> [ Html.code ?a l ]
 
 and styled style ~emph_level =
@@ -155,7 +155,7 @@ and inline ~config ?(emph_level = 0) ~resolve (l : Inline.t) :
     | Math s -> [ inline_math s ]
     | Raw_markup r -> raw_markup r
   in
-  Odoc_utils.List.concat_map ~f:one l
+  List.concat_map one l
 
 and inline_nolink ?(emph_level = 0) (l : Inline.t) :
     non_link_phrasing Html.elt list =
@@ -176,7 +176,7 @@ and inline_nolink ?(emph_level = 0) (l : Inline.t) :
     | Math s -> [ inline_math s ]
     | Raw_markup r -> raw_markup r
   in
-  Odoc_utils.List.concat_map ~f:one l
+  List.concat_map one l
 
 let heading ~config ~resolve (h : Heading.t) =
   let a, anchor =
@@ -290,7 +290,7 @@ let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
         mk_media_block image target alt
   in
 
-  Odoc_utils.List.concat_map l ~f:one
+  List.concat_map one l
 
 and mk_rows ~config ~resolve { align; data } =
   let mk_row row =
@@ -577,7 +577,7 @@ module Breadcrumbs = struct
     let find_parent =
       List.find_opt (function
         | ({ node = { url = { page; anchor = ""; _ }; _ }; _ } :
-            Odoc_document.Sidebar.entry Odoc_utils.Tree.t)
+            Odoc_document.Sidebar.entry Tree.t)
           when Url.Path.is_prefix page current_url ->
             true
         | _ -> false)

src/html/html_page.ml

@@ -78,7 +78,7 @@ let html_of_breadcrumbs (breadcrumbs : Types.breadcrumbs) =
   let sep = [ space; Html.entity "#x00BB"; space ] in
   let html =
     (* Create breadcrumbs *)
-    Odoc_utils.List.concat_map ~sep
+    List.concat_map_sep ~sep
       ~f:(fun (breadcrumb : Types.breadcrumb) ->
         match breadcrumb.href with
         | Some href ->

src/html/html_source.ml

@@ -1,3 +1,4 @@
+open Odoc_utils
 module HLink = Link
 open Odoc_document.Types
 open Tyxml
@@ -23,7 +24,7 @@ let html_of_doc ~config ~resolve docs =
     | Source_page.Plain_code s -> [ txt s ]
     | Tagged_code (info, docs) -> (
         let is_in_a = match info with Link _ -> true | _ -> is_in_a in
-        let children = List.concat @@ List.map (doc_to_html ~is_in_a) docs in
+        let children = List.concat_map (doc_to_html ~is_in_a) docs in
         match info with
         | Syntax tok -> [ span ~a:[ a_class [ tok ] ] children ]
         (* Currently, we do not render links to documentation *)
@@ -33,7 +34,8 @@ let html_of_doc ~config ~resolve docs =
             [ a ~a:[ a_href href ] children ]
         | Anchor lbl -> [ span ~a:[ a_id lbl ] children ])
   in
-  span ~a:[] @@ List.concat @@ List.map (doc_to_html ~is_in_a:false) docs
+  let span_content = List.concat_map (doc_to_html ~is_in_a:false) docs in
+  span ~a:[] span_content
 
 let count_lines_in_string s =
   let n = ref 0 in
@@ -45,9 +47,13 @@ let rec count_lines_in_span = function
   | Source_page.Plain_code s -> count_lines_in_string s
   | Tagged_code (_, docs) -> count_lines docs
 
-and count_lines = function
-  | [] -> 0
-  | hd :: tl -> count_lines_in_span hd + count_lines tl
+and count_lines l =
+  let rec inner l acc =
+    match l with
+    | [] -> acc
+    | hd :: tl -> inner tl (count_lines_in_span hd + acc)
+  in
+  inner l 0
 
 let rec line_numbers acc n =
   let open Html in

src/index/skeleton.ml

@@ -162,7 +162,7 @@ let rec unit (u : Compilation_unit.t) =
 
 and signature id (s : Signature.t) =
   let items = filter_signature s.items in
-  List.concat_map ~f:(signature_item (id :> Identifier.LabelParent.t)) items
+  List.concat_map (signature_item (id :> Identifier.LabelParent.t)) items
 
 and signature_item id s_item =
   match s_item with
@@ -215,8 +215,8 @@ and type_decl td =
     match td.representation with
     | None -> []
     | Some (Variant cl) ->
-        List.concat_map ~f:(constructor td.id td.equation.params) cl
-    | Some (Record fl) -> List.concat_map ~f:(field td.id td.equation.params) fl
+        List.concat_map (constructor td.id td.equation.params) cl
+    | Some (Record fl) -> List.concat_map (field td.id td.equation.params) fl
     | Some Extensible -> []
   in
   [ { Tree.node = entry; children } ]
@@ -288,7 +288,7 @@ and module_type_expr id mte =
 
 and class_signature id ct_expr =
   let items = filter_class_signature ct_expr.items in
-  List.concat_map ~f:(class_signature_item id) items
+  List.concat_map (class_signature_item id) items
 
 and class_signature_item id item =
   match item with

src/latex/generator.ml

@@ -218,7 +218,7 @@ let source k (t : Source.t) =
     | Elt i -> k i
     | Tag (None, l) -> tokens l
     | Tag (Some s, l) -> [ Tag (s, tokens l) ]
-  and tokens t = Odoc_utils.List.concat_map t ~f:token in
+  and tokens t = Odoc_utils.List.concat_map token t in
   tokens t
 
 let rec internalref ~verbatim ~in_source (t : Target.internal) (c : Inline.t) =
@@ -310,7 +310,7 @@ let rec block ~in_source (l : Block.t) =
           Break Paragraph;
         ]
   in
-  Odoc_utils.List.concat_map l ~f:one
+  Odoc_utils.List.concat_map one l
 
 and table_block { Table.data; align } =
   let data =

src/loader/ident_env.cppo.ml

@@ -201,7 +201,7 @@ let rec extract_signature_tree_items : bool -> Typedtree.signature_item list ->
 #else
   | { sig_desc = Tsig_type (_, decls); _} :: rest ->
 #endif
-    Odoc_utils.List.concat_map ~f:(fun decl ->
+    Odoc_utils.List.concat_map (fun decl ->
       if Btype.is_row_name (Ident.name decl.typ_id)
       then []
       else
@@ -337,7 +337,7 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list ->
 #else
     | { str_desc = Tstr_type (_, decls); _ } :: rest -> (* TODO: handle rec_flag *)
 #endif
-  Odoc_utils.List.concat_map ~f:(fun decl ->
+  Odoc_utils.List.concat_map (fun decl ->
       `Type (decl.typ_id, hide_item, Some decl.typ_loc) ::
         (match decl.typ_kind with
           Ttype_abstract -> []

src/syntax_highlighter/syntax_highlighter.ml

@@ -160,20 +160,21 @@ let syntax_highlighting_locs src =
         ~with_positions:true
   #endif
         src in
-    let rec collect lexbuf =
+    let rec collect lexbuf tokens =
       let tok = Lexer.token_with_comments lexbuf in
       let loc_start, loc_end = (lexbuf.lex_start_p, lexbuf.lex_curr_p) in
       let tag = tag_of_token tok in
       match tok with
-      | EOF -> []
+      | EOF -> List.rev tokens
       | COMMENT (_, loc) ->
-          (tag, (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum)) :: collect lexbuf
+          collect lexbuf ((tag, (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum)) :: tokens)
       | DOCSTRING doc ->
           let loc = Docstrings.docstring_loc doc in
-          (tag, (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum)) :: collect lexbuf
-      | _ -> (tag, (loc_start.pos_cnum, loc_end.pos_cnum)) :: collect lexbuf
+          collect lexbuf ((tag, (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum)) :: tokens)
+      | _ -> collect lexbuf ((tag, (loc_start.pos_cnum, loc_end.pos_cnum)) :: tokens)
     in
-    collect lexbuf
+    let result = collect lexbuf [] in
+    result
   with e ->
     Format.eprintf "Error during syntax highlighting: %s\n%!" (Printexc.to_string e);
     []

src/utils/odoc_list.ml

@@ -1,12 +1,21 @@
 include List
 
-let rec concat_map ?sep ~f = function
+let rec concat_map_sep ~sep ~f = function
   | [] -> []
   | [ x ] -> f x
-  | x :: xs -> (
+  | x :: xs ->
       let hd = f x in
-      let tl = concat_map ?sep ~f xs in
-      match sep with None -> hd @ tl | Some sep -> hd @ (sep :: tl))
+      let tl = concat_map_sep ~sep ~f xs in
+      hd @ (sep :: tl)
+
+let concat_map f l =
+  let rec aux f acc = function
+    | [] -> rev acc
+    | x :: l ->
+        let xs = f x in
+        aux f (rev_append xs acc) l
+  in
+  aux f [] l
 
 let rec filter_map acc f = function
   | hd :: tl ->