Merge pull request #864 from rgrinberg/doc-private

Refactor odoc generation and fix the private doc alias

CHANGES.md

@@ -66,6 +66,9 @@ next
   whether a multi valued variable is allowed is determined by the quoting and
   substitution context it appears in. (#849, fix #701, @rgrinberg)
 
+- Fix documentation generation for private libraries. (#864, fix #856,
+  @rgrinberg)
+
 1.0+beta20 (10/04/2018)
 -----------------------
 

src/odoc.ml

@@ -22,10 +22,20 @@ type target =
   | Lib of Lib.t
   | Pkg of Package.Name.t
 
+type source = Module | Mld
+
+type odoc =
+  { odoc_input: Path.t
+  ; html_dir: Path.t
+  ; html_file: Path.t
+  ; source: source
+  }
+
 module Gen (S : sig val sctx : SC.t end) = struct
   open S
 
   let context = SC.context sctx
+  let stanzas = SC.stanzas sctx
 
   module Paths = struct
     let root = context.Context.build_dir ++ "_doc"
@@ -138,14 +148,6 @@ module Gen (S : sig val sctx : SC.t end) = struct
          ]);
     odoc_file
 
-  type odoc =
-    { odoc_input: Path.t
-    ; html_dir: Path.t
-    ; html_file: Path.t
-    ; html_alias: Build_system.Alias.t
-    ; typ: [`Module | `Mld]
-    }
-
   let odoc_include_flags requires =
     Arg_spec.of_result_map requires ~f:(fun libs ->
       let paths =
@@ -159,11 +161,12 @@ module Gen (S : sig val sctx : SC.t end) = struct
       Arg_spec.S (List.concat_map (Path.Set.to_list paths)
                     ~f:(fun dir -> [Arg_spec.A "-I"; Path dir])))
 
-  let to_html (odoc_file : odoc) ~deps ~requires =
+  let setup_html (odoc_file : odoc) ~requires =
+    let deps = Dep.deps requires in
     let to_remove, jbuilder_keep =
-      match odoc_file.typ with
+      match odoc_file.source with
-      | `Mld -> odoc_file.html_file, []
+      | Mld -> odoc_file.html_file, []
-      | `Module ->
+      | Module ->
         let jbuilder_keep =
           Build.create_file (odoc_file.html_dir ++ Config.jbuilder_keep_fname) in
         odoc_file.html_dir, [jbuilder_keep]
@@ -182,10 +185,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
               ; Dep odoc_file.odoc_input
               ; Hidden_targets [odoc_file.html_file]
               ]
-         :: jbuilder_keep
+         :: jbuilder_keep))
-       )
-      );
-    odoc_file.html_file
 
   let css_file = Paths.html_root ++ "odoc.css"
 
@@ -259,12 +259,6 @@ module Gen (S : sig val sctx : SC.t end) = struct
     in
     SC.add_rule sctx @@ Build.write_file toplevel_index html
 
-
-  let html_alias pkg =
-    Build_system.Alias.doc ~dir:(
-      Path.append context.build_dir pkg.Package.path
-    )
-
   let libs_of_pkg ~pkg =
     match Package.Name.Map.find (SC.libs_by_package sctx) pkg with
     | None -> Lib.Set.empty
@@ -278,7 +272,6 @@ module Gen (S : sig val sctx : SC.t end) = struct
     pkg_libs
 
   let create_odoc ~target odoc_input =
-    let html_alias = Dep.html_alias target in
     let html_base = Paths.html target in
     match target with
     | Lib _ ->
@@ -291,8 +284,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
       { odoc_input
       ; html_dir
       ; html_file = html_dir ++ "index.html"
-      ; typ = `Module
+      ; source = Module
-      ; html_alias
       }
     | Pkg _ ->
       { odoc_input
@@ -303,52 +295,48 @@ module Gen (S : sig val sctx : SC.t end) = struct
           |> String.drop_prefix ~prefix:"page-"
           |> Option.value_exn
         )
-      ; typ = `Mld
+      ; source = Mld
-      ; html_alias
       }
 
+  let static_html = [ css_file; toplevel_index ]
+
+  let odocs =
+    let odoc_glob =
+      Re.compile (Re.seq [Re.(rep1 any) ; Re.str ".odoc" ; Re.eos]) in
+    fun target ->
+      let dir = Paths.odocs target in
+      SC.eval_glob sctx ~dir odoc_glob
+      |> List.map ~f:(fun d -> create_odoc (Path.relative dir d) ~target)
+
+  let setup_lib_html_rules =
+    let loaded = ref Lib.Set.empty in
+    fun lib ~requires ->
+      if not (Lib.Set.mem !loaded lib) then begin
+        loaded := Lib.Set.add !loaded lib;
+        let odocs = odocs (Lib lib) in
+        List.iter odocs ~f:(setup_html ~requires);
+        let html_files = List.map ~f:(fun o -> o.html_file) odocs in
+        SC.add_alias_deps sctx (Dep.html_alias (Lib lib))
+          (Path.Set.of_list (List.rev_append static_html html_files));
+      end
+
   let setup_pkg_html_rules =
     let loaded = Package.Name.Table.create ~default_value:false in
-    let odoc_glob =
-      Re.compile (Re.seq [Re.(rep1 any) ; Re.str ".odoc" ; Re.eos]) in
     fun ~pkg ~libs ->
       if not (Package.Name.Table.get loaded pkg) then begin
         Package.Name.Table.set loaded ~key:pkg ~data:true;
+        let requires = Lib.closure libs in
+        List.iter libs ~f:(setup_lib_html_rules ~requires);
+        let pkg_odocs = odocs (Pkg pkg) in
+        List.iter pkg_odocs ~f:(setup_html ~requires);
         let odocs =
-          let odocs target =
-            let dir = Paths.odocs target in
-            SC.eval_glob sctx ~dir odoc_glob
-            |> List.map ~f:(fun d -> create_odoc (Path.relative dir d) ~target)
-          in
           List.concat (
-            odocs (Pkg pkg)
+            pkg_odocs
             :: (List.map libs ~f:(fun lib -> odocs (Lib lib)))
           ) in
-        let html_files =
+        let html_files = List.map ~f:(fun o -> o.html_file) odocs in
-          let closure =
+        SC.add_alias_deps sctx (Dep.html_alias (Pkg pkg))
-            match Lib.closure libs with
+          (Path.Set.of_list (List.rev_append static_html html_files))
-            | Ok closure -> closure
-            | Error _ ->
-              (* CR diml for rgrinberg: this branch needs a comment, I
-                 don't understand why we fallback to not taking the
-                 transitive closure in case of error. *)
-              libs
-          in
-          let deps = Dep.deps (Ok closure) in
-          List.map odocs ~f:(to_html ~deps ~requires:(Ok closure)) in
-        List.iter (
-          Dep.html_alias (Pkg pkg)
-          :: List.map ~f:(fun lib -> Dep.html_alias (Lib lib)) libs
-        ) ~f:(fun alias ->
-          SC.add_alias_deps sctx alias
-            (Path.Set.of_list [ css_file
-                              ; toplevel_index
-                              ])
-        );
-        List.combine odocs html_files
-        |> List.iter ~f:(fun (odoc, html) ->
-          SC.add_alias_deps sctx odoc.html_alias (Path.Set.singleton html)
-        );
       end
 
   let gen_rules ~dir:_ rest =
@@ -366,25 +354,31 @@ module Gen (S : sig val sctx : SC.t end) = struct
       | Ok lib  -> SC.load_dir sctx ~dir:(Lib.src_dir lib)
       end
     | "_html" :: lib_unique_name_or_pkg :: _ ->
-      let setup_html_rules pkg =
-        setup_pkg_html_rules ~pkg ~libs:(
-          Lib.Set.to_list (load_all_odoc_rules_pkg ~pkg)
-        ) in
       (* TODO we can be a better with the error handling in the case where
          lib_unique_name_or_pkg is neither a valid pkg or lnu *)
       let lib, lib_db = SC.Scope_key.of_string sctx lib_unique_name_or_pkg in
+      let setup_pkg_html_rules pkg =
+        setup_pkg_html_rules ~pkg ~libs:(
+          Lib.Set.to_list (load_all_odoc_rules_pkg ~pkg)) in
       begin match Lib.DB.find lib_db lib with
       | Error _ -> ()
-      | Ok lib  -> Option.iter (Lib.package lib) ~f:setup_html_rules
+      | Ok lib ->
+        begin match Lib.package lib with
+        | None -> setup_lib_html_rules lib ~requires:(Lib.closure [lib])
+        | Some pkg -> setup_pkg_html_rules pkg
+        end
       end;
       Option.iter
         (Package.Name.Map.find (SC.packages sctx)
            (Package.Name.of_string lib_unique_name_or_pkg))
-        ~f:(fun pkg -> setup_html_rules pkg.name)
+        ~f:(fun pkg -> setup_pkg_html_rules pkg.name)
     | _ -> ()
 
   let setup_package_aliases (pkg : Package.t) =
-    let alias = html_alias pkg in
+    let alias =
+      Build_system.Alias.doc ~dir:(
+        Path.append context.build_dir pkg.Package.path
+      ) in
     SC.add_alias_deps sctx alias (
       Dep.html_alias (Pkg pkg.name)
       :: (libs_of_pkg ~pkg:pkg.name
@@ -468,7 +462,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
   let init ~modules_by_lib ~mlds_of_dir =
     let docs_by_package =
       let map = lazy (
-        SC.stanzas sctx
+        stanzas
         |> List.concat_map ~f:(fun (w : SC.Dir_with_jbuild.t) ->
           List.filter_map w.stanzas ~f:(function
             | Documentation (d : Jbuild.Documentation.t) ->
@@ -491,7 +485,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
           | o -> o
       end) in
       let lib_to_library = lazy (
-        SC.stanzas sctx
+        stanzas
         |> List.concat_map ~f:(fun (w : SC.Dir_with_jbuild.t) ->
           List.filter_map w.stanzas ~f:(function
             | Jbuild.Library (l : Library.t) ->
@@ -529,7 +523,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
     Super_context.add_alias_deps
       sctx
       (Build_system.Alias.private_doc ~dir:context.build_dir)
-      (SC.stanzas sctx
+      (stanzas
        |> List.concat_map ~f:(fun (w : SC.Dir_with_jbuild.t) ->
          List.filter_map w.stanzas ~f:(function
            | Jbuild.Library (l : Jbuild.Library.t) ->
@@ -544,7 +538,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
            | _ -> None
          ))
        |> List.map ~f:(fun (lib : Lib.t) ->
-         Build_system.Alias.stamp_file (Dep.alias (Lib lib)))
+         Build_system.Alias.stamp_file (Dep.html_alias (Lib lib)))
        |> Path.Set.of_list
       )
 

test/blackbox-tests/test-cases/multiple-private-libs/run.t

@@ -1,9 +1,12 @@
 This test checks that there is no clash when two private libraries have the same name
 
   $ dune build --display short @doc-private
+          odoc _doc/_html/odoc.css
       ocamldep a/test.ml.d
         ocamlc a/.test.objs/test.{cmi,cmo,cmt}
           odoc _doc/_odoc/lib/test@a/test.odoc
+          odoc _doc/_html/test@a/Test/.jbuilder-keep,_doc/_html/test@a/Test/index.html
       ocamldep b/test.ml.d
         ocamlc b/.test.objs/test.{cmi,cmo,cmt}
           odoc _doc/_odoc/lib/test@b/test.odoc
+          odoc _doc/_html/test@b/Test/.jbuilder-keep,_doc/_html/test@b/Test/index.html