Resolver: Separate root for libraries and packages

The "current_root" for pages and module lookups are computed or
validated separately and are made optional.

This allows to represent cases where a page have no current library or a
module have no current package.

Also removes the empty string root being used when no -P or -P are
passed, a new error case is added for this case.

src/odoc/bin/main.ml

@@ -592,46 +592,70 @@ end = struct
 
   open Or_error
 
-  (** Find the package name the output is part of *)
-  let find_package_of_output l o =
+  (** Find the package/library name the output is part of *)
+  let find_root_of_output l o =
     let l =
       List.map
         ~f:(fun (x, p) ->
           (x, p |> Fs.Directory.to_fpath |> absolute_normalization))
         l
     in
     let o = absolute_normalization o in
-    match
-      (* Taken from OCaml 5.2 standard library *)
-      let rec find_map ~f = function
-        | [] -> None
-        | x :: l -> (
-            match f x with Some _ as result -> result | None -> find_map ~f l)
-      in
-      find_map
-        ~f:(fun (pkg, path) ->
-          if Fpath.is_prefix path o then Some pkg else None)
-        l
-    with
-    | Some pkg -> Ok pkg
-    | None ->
-        if List.length l > 0 then
-          Error
-            (`Msg
-              "The output file must be part of a directory passed as a -P or -L")
-        else Ok ""
-
-  let validate_current_package page_roots current_package =
+    (* Taken from OCaml 5.2 standard library *)
+    let rec find_map ~f = function
+      | [] -> None
+      | x :: l -> (
+          match f x with Some _ as result -> result | None -> find_map ~f l)
+    in
+    match l with
+    | [] -> Ok None
+    | _ -> (
+        match
+          find_map
+            ~f:(fun (pkg, path) ->
+              if Fpath.is_prefix path o then Some pkg else None)
+            l
+        with
+        | Some _ as r -> Ok r
+        | None -> Error `Not_found)
+
+  let current_library_of_output lib_roots output =
+    match find_root_of_output lib_roots output with
+    | Ok _ as ok -> ok
+    | Error `Not_found ->
+        Error (`Msg "The output file must be part of a directory passed as -L")
+
+  (** Whether if the package specified with [--current-package] is consistent
+      with the pages roots and with the output path for pages. *)
+  let validate_current_package ?detected_package page_roots current_package =
     match current_package with
-    | Some curpkgnane ->
-        if List.exists ~f:(fun (pkgname, _) -> pkgname = curpkgnane) page_roots
-        then Ok ()
-        else
+    | Some curpkgnane -> (
+        if
+          not
+            (List.exists
+               ~f:(fun (pkgname, _) -> pkgname = curpkgnane)
+               page_roots)
+        then
           Error
             (`Msg
               "The package name specified with --current-package do not match \
-               any package passed as a -P.")
-    | None -> Ok ()
+               any package passed as a -P")
+        else
+          match detected_package with
+          | Some dpkg when dpkg <> curpkgnane ->
+              Error
+                (`Msg
+                  "The package name specified with --current-package is not \
+                   consistent with the packages passed as a -P")
+          | _ -> Ok current_package)
+    | None -> Ok detected_package
+
+  let current_package_of_page ~current_package page_roots output =
+    match find_root_of_output page_roots output with
+    | Ok detected_package ->
+        validate_current_package ?detected_package page_roots current_package
+    | Error `Not_found ->
+        Error (`Msg "The output file must be part of a directory passed as -P")
 
   let is_page input =
     input |> Fpath.filename |> Astring.String.is_prefix ~affix:"page-"
@@ -645,12 +669,14 @@ end = struct
          (`Msg "Arguments given to -P and -L cannot be included in each others")
      else Ok ())
     >>= fun () ->
-    (if is_page input then find_package_of_output page_roots output
-     else find_package_of_output lib_roots output)
-    >>= fun current_root ->
-    validate_current_package page_roots current_package >>= fun () ->
+    let is_page = is_page input in
+    (if is_page then Ok None else current_library_of_output lib_roots output)
+    >>= fun current_lib ->
+    (if is_page then current_package_of_page ~current_package page_roots output
+     else validate_current_package page_roots current_package)
+    >>= fun current_package ->
     let roots =
-      Some { Resolver.page_roots; lib_roots; current_root; current_package }
+      Some { Resolver.page_roots; lib_roots; current_lib; current_package }
     in
     let resolver =
       Resolver.create ~important_digests:false ~directories ~open_modules ~roots

src/odoc/resolver.ml

@@ -36,9 +36,9 @@ open Or_error
 module Named_roots : sig
   type t
 
-  type error = NoPackage
+  type error = NoPackage | NoRoot
 
-  val create : (string * Fs.Directory.t) list -> current_root:string -> t
+  val create : (string * Fs.Directory.t) list -> current_root:string option -> t
 
   val find_by_path :
     ?root:string -> t -> path:Fs.File.t -> (Fs.File.t option, error) result
@@ -54,9 +54,9 @@ end = struct
 
   type pkg = { flat : flat; hierarchical : hierarchical }
 
-  type t = { table : (string, pkg) Hashtbl.t; current_root : string }
+  type t = { table : (string, pkg) Hashtbl.t; current_root : string option }
 
-  type error = NoPackage
+  type error = NoPackage | NoRoot
 
   let hashtbl_find_opt cache package =
     match Hashtbl.find cache package with
@@ -75,18 +75,23 @@ end = struct
 
   let find_by_path ?root { table = cache; current_root } ~path =
     let path = Fpath.normalize path in
-    let root = match root with None -> current_root | Some pkg -> pkg in
-    match hashtbl_find_opt cache root with
-    | Some { hierarchical = cache, root; _ } -> (
-        match hashtbl_find_opt cache path with
-        | Some x -> Ok (Some x)
-        | None ->
-            let full_path = Fpath.( // ) (Fs.Directory.to_fpath root) path in
-            if Fs.File.exists full_path then (
-              Hashtbl.add cache path full_path;
-              Ok (Some full_path))
-            else Ok None)
-    | None -> Error NoPackage
+    let root = match root with None -> current_root | Some _ as pkg -> pkg in
+    match root with
+    | Some root -> (
+        match hashtbl_find_opt cache root with
+        | Some { hierarchical = cache, root; _ } -> (
+            match hashtbl_find_opt cache path with
+            | Some x -> Ok (Some x)
+            | None ->
+                let full_path =
+                  Fpath.( // ) (Fs.Directory.to_fpath root) path
+                in
+                if Fs.File.exists full_path then (
+                  Hashtbl.add cache path full_path;
+                  Ok (Some full_path))
+                else Ok None)
+        | None -> Error NoPackage)
+    | None -> Error NoRoot
 
   let populate_flat_namespace ~root =
     let flat_namespace = Hashtbl.create 42 in
@@ -105,14 +110,19 @@ end = struct
     flat_namespace
 
   let find_by_name ?root { table = cache; current_root } ~name =
-    let package = match root with None -> current_root | Some pkg -> pkg in
-    match hashtbl_find_opt cache package with
-    | Some { flat = Visited flat; _ } -> Ok (Hashtbl.find_all flat name)
-    | Some ({ flat = Unvisited root; _ } as p) ->
-        let flat = populate_flat_namespace ~root in
-        Hashtbl.replace cache package { p with flat = Visited flat };
-        Ok (Hashtbl.find_all flat name)
-    | None -> Error NoPackage
+    let package =
+      match root with None -> current_root | Some _ as pkg -> pkg
+    in
+    match package with
+    | Some package -> (
+        match hashtbl_find_opt cache package with
+        | Some { flat = Visited flat; _ } -> Ok (Hashtbl.find_all flat name)
+        | Some ({ flat = Unvisited root; _ } as p) ->
+            let flat = populate_flat_namespace ~root in
+            Hashtbl.replace cache package { p with flat = Visited flat };
+            Ok (Hashtbl.find_all flat name)
+        | None -> Error NoPackage)
+    | None -> Error NoRoot
 end
 
 let () = (ignore Named_roots.find_by_name [@warning "-5"])
@@ -342,7 +352,8 @@ let lookup_page ~pages ap target_name =
               Format.eprintf "%s\n"
               @@ "Error during find by path: no package was found with this \
                   name";
-              None)
+              None
+          | Error NoRoot -> None)
       | _ -> failwith "Relative references (a/b, ../a/b) are not yet tested")
   | _ -> (
       let target_name = "page-" ^ target_name in
@@ -389,7 +400,7 @@ type t = {
 type roots = {
   page_roots : (string * Fs.Directory.t) list;
   lib_roots : (string * Fs.Directory.t) list;
-  current_root : string;
+  current_lib : string option;
   current_package : string option;
 }
 
@@ -398,9 +409,9 @@ let create ~important_digests ~directories ~open_modules ~roots =
   let pages, libs =
     match roots with
     | None -> (None, None)
-    | Some { page_roots; lib_roots; current_root; _ } ->
-        ( Some (Named_roots.create ~current_root page_roots),
-          Some (Named_roots.create ~current_root lib_roots) )
+    | Some { page_roots; lib_roots; current_lib; current_package } ->
+        ( Some (Named_roots.create ~current_root:current_package page_roots),
+          Some (Named_roots.create ~current_root:current_lib lib_roots) )
   in
   { important_digests; ap; open_modules; pages; libs }
 

src/odoc/resolver.mli

@@ -24,7 +24,7 @@ type t
 type roots = {
   page_roots : (string * Fs.Directory.t) list;
   lib_roots : (string * Fs.Directory.t) list;
-  current_root : string;
+  current_lib : string option;
   current_package : string option;
 }