Docs CI compatibility

CHANGES.md

@@ -69,6 +69,8 @@
 - Fix misprinting of type variables from ml files for OCaml 4.14 and later
   (multiple occurences of the same type variable could be named differently)
   (@octachron, #1173)
+- Fix bug where source rendering would cause odoc to fail completely if it
+  encounters invalid syntax (@jonludlam #1208)
 
 
 # 2.4.0

odoc-driver.opam

@@ -45,6 +45,7 @@ depends: [
   "progress"
   "cmdliner"
   "sexplib"
+  "ppx_sexp_conv"
 ]
 
 build: [

src/driver/compile.ml

@@ -8,7 +8,11 @@ let mk_byhash (pkgs : Odoc_unit.t list) =
   List.fold_left
     (fun acc (u : Odoc_unit.t) ->
       match u.Odoc_unit.kind with
-      | `Intf { hash; _ } as kind -> Util.StringMap.add hash { u with kind } acc
+      | `Intf { hash; _ } as kind ->
+          let elt = { u with kind } in
+          Util.StringMap.update hash
+            (function None -> Some [ elt ] | Some x -> Some (elt :: x))
+            acc
       | _ -> acc)
     Util.StringMap.empty pkgs
 
@@ -50,8 +54,8 @@ let init_stats (units : Odoc_unit.t list) =
 open Eio.Std
 
 type partial =
-  (string * Odoc_unit.intf Odoc_unit.unit) list
-  * Odoc_unit.intf Odoc_unit.unit Util.StringMap.t
+  (string * Odoc_unit.intf Odoc_unit.unit list) list
+  * Odoc_unit.intf Odoc_unit.unit list Util.StringMap.t
 
 let unmarshal filename : partial =
   let ic = open_in_bin (Fpath.to_string filename) in
@@ -66,8 +70,8 @@ let marshal (v : partial) filename =
     ~finally:(fun () -> close_out oc)
     (fun () -> Marshal.to_channel oc v [])
 
-let find_partials odoc_dir : Odoc_unit.intf Odoc_unit.unit Util.StringMap.t * _
-    =
+let find_partials odoc_dir :
+    Odoc_unit.intf Odoc_unit.unit list Util.StringMap.t * _ =
   let tbl = Hashtbl.create 1000 in
   let hashes_result =
     OS.Dir.fold_contents ~dotfiles:false ~elements:`Dirs
@@ -100,42 +104,47 @@ let compile ?partial ~partial_dir ?linked_dir:_ (all : Odoc_unit.t list) =
       | None -> (Util.StringMap.empty, Hashtbl.create 10)
     in
     let all_hashes =
-      Util.StringMap.union (fun _x o1 _o2 -> Some o1) hashes other_hashes
+      Util.StringMap.union (fun _x o1 o2 -> Some (o1 @ o2)) hashes other_hashes
     in
     let compile_one compile_other hash =
       match Util.StringMap.find_opt hash all_hashes with
       | None ->
           Logs.debug (fun m -> m "Error locating hash: %s" hash);
           Error Not_found
-      | Some unit ->
-          let deps = match unit.kind with `Intf { deps; _ } -> deps in
-          let _fibers =
-            Fiber.List.map
-              (fun (other_unit : Odoc_unit.intf Odoc_unit.unit) ->
-                match compile_other other_unit with
-                | Ok r -> Some r
-                | Error _exn ->
-                    Logs.debug (fun m ->
-                        m
-                          "Error during compilation of module %s (hash %s, \
-                           required by %s)"
-                          (Fpath.filename other_unit.input_file)
-                          (match other_unit.kind with
-                          | `Intf { hash; _ } -> hash)
-                          (Fpath.filename unit.input_file));
-                    None)
-              deps
-          in
-          let includes = Fpath.Set.of_list unit.include_dirs in
-          Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
-            ~includes ~parent_id:unit.parent_id;
-          Atomic.incr Stats.stats.compiled_units;
+      | Some units ->
+          Ok
+            (List.map
+               (fun (unit : Odoc_unit.intf Odoc_unit.unit) ->
+                 let deps = match unit.kind with `Intf { deps; _ } -> deps in
+                 let _fibers =
+                   Fiber.List.map
+                     (fun (other_unit : Odoc_unit.intf Odoc_unit.unit) ->
+                       match compile_other other_unit with
+                       | Ok r -> Some r
+                       | Error _exn ->
+                           Logs.debug (fun m ->
+                               m
+                                 "Error during compilation of module %s (hash \
+                                  %s, required by %s)"
+                                 (Fpath.filename other_unit.input_file)
+                                 (match other_unit.kind with
+                                 | `Intf { hash; _ } -> hash)
+                                 (Fpath.filename unit.input_file));
+                           None)
+                     deps
+                 in
+                 let includes = unit.include_dirs in
+                 Odoc.compile ~output_dir:unit.output_dir
+                   ~input_file:unit.input_file ~includes
+                   ~parent_id:unit.parent_id;
+                 Atomic.incr Stats.stats.compiled_units;
 
-          Ok unit
+                 unit)
+               units)
     in
     let rec compile_mod :
         Odoc_unit.intf Odoc_unit.unit ->
-        (Odoc_unit.intf Odoc_unit.unit, exn) Result.t =
+        (Odoc_unit.intf Odoc_unit.unit list, exn) Result.t =
      fun unit ->
       let hash = match unit.kind with `Intf { hash; _ } -> hash in
       match Hashtbl.find_opt tbl hash with
@@ -153,33 +162,43 @@ let compile ?partial ~partial_dir ?linked_dir:_ (all : Odoc_unit.t list) =
   let compile (unit : Odoc_unit.t) =
     match unit.kind with
     | `Intf _ as kind ->
-        (compile_mod { unit with kind } :> (Odoc_unit.t, _) Result.t)
+        (compile_mod { unit with kind } :> (Odoc_unit.t list, _) Result.t)
     | `Impl src ->
-        let includes = Fpath.Set.of_list unit.include_dirs in
+        let includes = unit.include_dirs in
         let source_id = src.src_id in
         Odoc.compile_impl ~output_dir:unit.output_dir
           ~input_file:unit.input_file ~includes ~parent_id:unit.parent_id
           ~source_id;
         Atomic.incr Stats.stats.compiled_impls;
-        Ok unit
+        Ok [ unit ]
     | `Asset ->
         Odoc.compile_asset ~output_dir:unit.output_dir ~parent_id:unit.parent_id
           ~name:(Fpath.filename unit.input_file);
         Atomic.incr Stats.stats.compiled_assets;
-        Ok unit
+        Ok [ unit ]
     | `Mld ->
-        let includes = Fpath.Set.of_list unit.include_dirs in
+        let includes = unit.include_dirs in
         Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
           ~includes ~parent_id:unit.parent_id;
         Atomic.incr Stats.stats.compiled_mlds;
-        Ok unit
+        Ok [ unit ]
   in
   let res = Fiber.List.map compile all in
   (* For voodoo mode, we need to keep which modules successfully compiled *)
   let zipped =
     List.filter_map
       (function
-        | Ok (Odoc_unit.{ kind = `Intf { hash; _ }; _ } as b) -> Some (hash, b)
+        | Ok (Odoc_unit.{ kind = `Intf { hash; _ }; _ } :: _ as b) ->
+            let l =
+              List.filter_map
+                (function
+                  | Odoc_unit.{ kind = `Intf { hash = hash'; _ }; _ } as x
+                    when hash' = hash ->
+                      Some x
+                  | _ -> None)
+                b
+            in
+            Some (hash, l)
         | _ -> None)
       res
   in
@@ -195,8 +214,9 @@ let link : compiled list -> _ =
   let link : compiled -> linked =
    fun c ->
     let link input_file output_file =
-      let { Odoc_unit.libs; pages } = c.pkg_args in
-      let includes = c.include_dirs |> Fpath.Set.of_list in
+      let libs = Odoc_unit.Pkg_args.compiled_libs c.pkg_args in
+      let pages = Odoc_unit.Pkg_args.compiled_pages c.pkg_args in
+      let includes = c.include_dirs in
       Odoc.link ~input_file ~output_file ~includes ~libs ~docs:pages
         ~current_package:c.pkgname ()
     in
@@ -232,12 +252,13 @@ let html_generate ~occurrence_file output_dir linked =
   let compile_index : Odoc_unit.index -> _ =
    fun index ->
     let compile_index_one
-        ({ pkg_args = { pages; libs }; output_file; json; search_dir = _ } as
-         index :
+        ({ pkg_args; output_file; json; search_dir = _ } as index :
           Odoc_unit.index) =
+      let libs_linked = Odoc_unit.Pkg_args.linked_libs pkg_args in
+      let pages_linked = Odoc_unit.Pkg_args.linked_pages pkg_args in
       let () =
-        Odoc.compile_index ~json ~occurrence_file ~output_file ~libs ~docs:pages
-          ()
+        Odoc.compile_index ~json ~occurrence_file ~output_file ~libs:libs_linked
+          ~docs:pages_linked ()
       in
       sherlodoc_index_one ~output_dir index
     in
@@ -260,6 +281,8 @@ let html_generate ~occurrence_file output_dir linked =
     | `Impl { src_path; _ } ->
         Odoc.html_generate_source ~search_uris:[] ~output_dir ~input_file
           ~source:src_path ();
+        Odoc.html_generate_source ~search_uris:[] ~output_dir ~input_file
+          ~source:src_path ~as_json:true ();
         Atomic.incr Stats.stats.generated_units
     | `Asset ->
         Odoc.html_generate_asset ~output_dir ~input_file:l.odoc_file
@@ -275,6 +298,8 @@ let html_generate ~occurrence_file output_dir linked =
               (Some search_uris, Some index)
         in
         Odoc.html_generate ?search_uris ?index ~output_dir ~input_file ();
+        Odoc.html_generate ?search_uris ?index ~output_dir ~input_file
+          ~as_json:true ();
         Atomic.incr Stats.stats.generated_units
   in
   Fiber.List.iter html_generate linked

src/driver/dune

@@ -3,6 +3,8 @@
  (package odoc-driver)
  (link_deps
   (package odoc))
+ (preprocess
+  (pps ppx_sexp_conv))
  (libraries
   cmdliner
   bos

src/driver/dune_style.ml

@@ -1,4 +1,43 @@
 (* Dune build tree *)
+open Bos
+open Sexplib.Std
+[@@@warning "-69-30"]
+let dune = ref (Cmd.v "dune")
+
+type item = Library of library
+
+and items = item list
+
+and library = {
+  name : string;
+  uid : uid;
+  local : bool;
+  requires : uid list;
+  source_dir : string;
+  modules : Sexplib.Sexp.t list;
+  include_dirs : string list;
+}
+
+and library_list = library list
+
+and uid = string [@@deriving sexp]
+
+let of_dune_describe txt =
+  let sexp = Sexplib.Sexp.of_string txt in
+  let open Sexplib0.Sexp in
+  match sexp with
+  | Atom _ -> []
+  | List ls ->
+      let libs =
+        List.filter_map (fun s -> try Some (item_of_sexp s) with _ -> None) ls
+      in
+      libs
+let dune_describe dir =
+  let cmd = Cmd.(!dune % "describe" % "--root" % p dir) in
+  let out = Worker_pool.submit "dune describe" cmd None in
+  match out with
+  | Error _ -> []
+  | Ok out -> of_dune_describe (String.concat "\n" out)
 
 let of_dune_build dir =
   let contents =
@@ -8,6 +47,30 @@ let of_dune_build dir =
   | Error _ -> Util.StringMap.empty
   | Ok c ->
       let sorted = List.sort (fun p1 p2 -> Fpath.compare p1 p2) c in
+      let libs = dune_describe dir in
+      let local_libs =
+        List.filter_map
+          (function Library l -> if l.local then Some l else None)
+          libs
+      in
+      let uid_to_libname =
+        List.fold_left
+          (fun acc l -> Util.StringMap.add l.uid l.name acc)
+          Util.StringMap.empty local_libs
+      in
+      let all_lib_deps =
+        List.fold_left
+          (fun acc l ->
+            Util.StringMap.add l.name
+              (List.filter_map
+                 (fun uid -> Util.StringMap.find_opt uid uid_to_libname)
+                 l.requires
+              |> Util.StringSet.of_list)
+              acc)
+          Util.StringMap.empty local_libs
+      in
+      (* Format.eprintf "all_lib_deps: %a@." Fmt.(list ~sep:comma (pair string (list ~sep:semi string))) (Util.StringMap.to_list all_lib_deps); *)
+      (* Format.eprintf "libs: %s@." (Sexplib.Sexp.to_string_hum (sexp_of_library_list local_libs)); *)
       let libs =
         List.filter_map
           (fun x ->
@@ -37,8 +100,10 @@ let of_dune_build dir =
             let pkg_dir = Fpath.rem_prefix dir path |> Option.get in
             ( pkg_dir,
               Packages.Lib.v
-                ~libname_of_archive:(Util.StringMap.singleton libname libname)
-                ~pkg_name:libname ~dir:path ~cmtidir:(Some cmtidir) ))
+                ~libname_of_archive:
+                  (Fpath.Map.singleton Fpath.(path / libname) libname)
+                ~pkg_name:libname ~dir:path ~cmtidir:(Some cmtidir)
+                ~all_lib_deps ~cmi_only_libs:[] ))
           libs
       in
       let packages =