New odoc rules (ocaml#8803)

* New odoc rules

Signed-off-by: Jon Ludlam <jon@recoil.org>
Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

doc/changes/8803.md

@@ -0,0 +1 @@
+- Introduce new experimental odoc rules (#8803, @jonjudlam)

otherlibs/stdune/src/string.ml

@@ -296,3 +296,14 @@ let drop_prefix_and_suffix t ~prefix ~suffix =
   then Some (sub t ~pos:p_len ~len:(t_len - p_s_len))
   else None
 ;;
+
+let contains_double_underscore =
+  let rec aux s len i =
+    if i > len - 2
+    then false
+    else if s.[i] = '_' && s.[i + 1] = '_'
+    then true
+    else aux s len (i + 1)
+  in
+  fun s -> aux s (String.length s) 0
+;;

otherlibs/stdune/src/string.mli

@@ -107,3 +107,4 @@ val quote_for_shell : string -> string
 val quote_list_for_shell : string list -> string
 
 val filter_map : string -> f:(char -> char option) -> string
+val contains_double_underscore : string -> bool

src/dune_rules/alias0.ml

@@ -11,6 +11,7 @@ let lint = standard "lint"
 let private_doc = standard "doc-private"
 let doc = standard "doc"
 let doc_json = standard "doc-json"
+let doc_new = standard "doc-new"
 let check = standard "check"
 let install = standard "install"
 let runtest = standard "runtest"

src/dune_rules/alias0.mli

@@ -9,6 +9,7 @@ val doc : Name.t
 val doc_json : Name.t
 val lint : Name.t
 val private_doc : Name.t
+val doc_new : Name.t
 val check : Name.t
 val install : Name.t
 val runtest : Name.t

src/dune_rules/dir_contents.ml

@@ -452,14 +452,20 @@ end
 
 include Load
 
+let modules_of_local_lib sctx lib =
+  let info = Lib.Local.info lib in
+  let dir = Lib_info.src_dir info in
+  let* t = get sctx ~dir in
+  let+ ml_sources = ocaml t in
+  let name = Lib_info.name info in
+  Ml_sources.modules ml_sources ~for_:(Library name)
+;;
+
 let modules_of_lib sctx lib =
   let info = Lib.info lib in
   match Lib_info.modules info with
   | External modules -> Memo.return modules
   | Local ->
-    let dir = Lib_info.src_dir info |> Path.as_in_build_dir_exn in
-    let* t = get sctx ~dir in
-    let+ ml_sources = ocaml t in
-    let name = Lib.name lib in
-    Some (Ml_sources.modules ml_sources ~for_:(Library name))
+    let+ modules = modules_of_local_lib sctx (Lib.Local.of_lib_exn lib) in
+    Some modules
 ;;

src/dune_rules/dir_contents.mli

@@ -35,6 +35,7 @@ val coq : t -> Coq_sources.t Memo.t
 val get : Super_context.t -> dir:Path.Build.t -> t Memo.t
 
 val modules_of_lib : Super_context.t -> Lib.t -> Modules.t option Memo.t
+val modules_of_local_lib : Super_context.t -> Lib.Local.t -> Modules.t Memo.t
 
 (** All directories in this group if [t] is a group root or just [t] if it is
     not part of a group. *)

src/dune_rules/dune_package.ml

@@ -6,31 +6,69 @@ module Vfile = Dune_lang.Versioned_file.Make (struct
 
 let fn = "dune-package"
 
+module External_location = struct
+  type t =
+    | Relative_to_stdlib of Path.Local.t
+    | Relative_to_findlib of (Path.t * Path.Local.t)
+    | Absolute of Path.t
+
+  let to_dyn x =
+    let open Dyn in
+    match x with
+    | Relative_to_stdlib p -> variant "Relative_to_stdlib" [ Path.Local.to_dyn p ]
+    | Relative_to_findlib (p1, p2) ->
+      variant "Relative_to_findlib" [ pair Path.to_dyn Path.Local.to_dyn (p1, p2) ]
+    | Absolute p -> variant "Absolute" [ Path.to_dyn p ]
+  ;;
+
+  let compare x y =
+    match x, y with
+    | Relative_to_stdlib x, Relative_to_stdlib y -> Path.Local.compare x y
+    | Relative_to_findlib (x1, x2), Relative_to_findlib (y1, y2) ->
+      let open Ordering.O in
+      let= () = Path.compare x1 y1 in
+      Path.Local.compare x2 y2
+    | Absolute x, Absolute y -> Path.compare x y
+    | Relative_to_stdlib _, _ -> Lt
+    | _, Relative_to_stdlib _ -> Gt
+    | Relative_to_findlib _, Absolute _ -> Lt
+    | Absolute _, Relative_to_findlib _ -> Gt
+  ;;
+
+  let hash = Poly.hash
+end
+
 module Lib = struct
   type t =
     { info : Path.t Lib_info.t
     ; main_module_name : Module_name.t option
+    ; external_location : External_location.t option
     }
 
-  let make ~info ~main_module_name =
+  let make ~info ~main_module_name ~external_location =
     let obj_dir = Lib_info.obj_dir info in
     let dir = Obj_dir.dir obj_dir in
     let map_path p =
       if Path.is_managed p then Path.relative dir (Path.basename p) else p
     in
     let info = Lib_info.map_path info ~f:map_path in
-    { info; main_module_name }
+    { info; main_module_name; external_location }
+  ;;
+
+  let of_dune_lib ~info ~main_module_name =
+    make ~info ~main_module_name ~external_location:None
   ;;
 
-  let of_dune_lib ~info ~main_module_name = make ~info ~main_module_name
-  let of_findlib info = make ~info ~main_module_name:None
+  let of_findlib info external_location =
+    make ~info ~main_module_name:None ~external_location:(Some external_location)
+  ;;
 
   let dir_of_name name =
     let _, components = Lib_name.split name in
     Path.Local.L.relative Path.Local.root components
   ;;
 
-  let encode ~package_root ~stublibs { info; main_module_name } =
+  let encode ~package_root ~stublibs { info; main_module_name; external_location = _ } =
     let open Dune_lang.Encoder in
     let no_loc f (_loc, x) = f x in
     let path = Dune_lang.Path.Local.encode ~dir:package_root in
@@ -259,7 +297,17 @@ module Lib = struct
            ~instrumentation_backend
            ~melange_runtime_deps
        in
-       { info; main_module_name })
+       let external_location =
+         let opam_dir = Path.parent_exn base in
+         let pkg, components = Lib_name.split name in
+         let local =
+           Path.Local.L.relative
+             (Path.Local.of_string (Package.Name.to_string pkg))
+             components
+         in
+         Some (External_location.Relative_to_findlib (opam_dir, local))
+       in
+       { info; main_module_name; external_location })
   ;;
 
   let main_module_name t = t.main_module_name
@@ -271,12 +319,14 @@ module Lib = struct
   ;;
 
   let info dp = dp.info
+  let external_location dp = dp.external_location
 
-  let to_dyn { info; main_module_name } =
+  let to_dyn { info; main_module_name; external_location } =
     let open Dyn in
     record
       [ "info", Lib_info.to_dyn Path.to_dyn info
       ; "main_module_name", option Module_name.to_dyn main_module_name
+      ; "external_location", option External_location.to_dyn external_location
       ]
   ;;
 end

src/dune_rules/dune_package.mli

@@ -5,14 +5,26 @@ open Import
 (** The filename of a dune-package file*)
 val fn : string
 
+module External_location : sig
+  type t =
+    | Relative_to_stdlib of Path.Local.t
+    | Relative_to_findlib of (Path.t * Path.Local.t)
+    | Absolute of Path.t
+
+  val to_dyn : t Dyn.builder
+  val compare : t -> t -> Ordering.t
+  val hash : t -> int
+end
+
 module Lib : sig
   type t
 
   val main_module_name : t -> Module_name.t option
   val dir_of_name : Lib_name.t -> Path.Local.t
   val wrapped : t -> Wrapped.t option
   val info : t -> Path.t Lib_info.t
-  val of_findlib : Path.t Lib_info.t -> t
+  val external_location : t -> External_location.t option
+  val of_findlib : Path.t Lib_info.t -> External_location.t -> t
   val of_dune_lib : info:Path.t Lib_info.t -> main_module_name:Module_name.t option -> t
   val to_dyn : t Dyn.builder
 end

src/dune_rules/findlib.ml

@@ -85,22 +85,7 @@ module DB = struct
   ;;
 end
 
-let has_double_underscore s =
-  let len = String.length s in
-  len >= 2
-  &&
-  let last = ref s.[0] in
-  try
-    for i = 1 to len - 1 do
-      let c = s.[i] in
-      if c = '_' && !last = '_' then raise_notrace Exit else last := c
-    done;
-    false
-  with
-  | Exit -> true
-;;
-
-let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib =
+let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_location =
   let loc = Loc.in_file t.meta_file in
   let add_loc x = loc, x in
   let archives = Findlib.Package.archives t in
@@ -206,7 +191,7 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib =
                 | true ->
                   if (* We add this hack to skip manually mangled
                         libraries *)
-                     has_double_underscore fname
+                     String.contains_double_underscore fname
                   then Ok None
                   else (
                     match
@@ -256,33 +241,46 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib =
       ~instrumentation_backend:None
       ~melange_runtime_deps
   in
-  Dune_package.Lib.of_findlib info
+  Dune_package.Lib.of_findlib info external_location
 ;;
 
 module Loader = struct
   open Memo.O
 
   (* Parse all the packages defined in a META file *)
-  let dune_package_of_meta (db : DB.t) ~dir ~meta_file ~(meta : Meta.Simplified.t) =
-    let rec loop ~dir ~full_name (meta : Meta.Simplified.t) acc =
+  let dune_package_of_meta (db : DB.t) ~loc ~meta_file ~(meta : Meta.Simplified.t) =
+    let dir_of_loc (loc : Dune_package.External_location.t) =
+      match loc with
+      | Absolute d -> d
+      | Relative_to_findlib (dir, l) -> Path.relative dir (Path.Local.to_string l)
+      | Relative_to_stdlib l -> Path.relative db.stdlib_dir (Path.Local.to_string l)
+    in
+    let rec loop ~loc ~full_name (meta : Meta.Simplified.t) acc =
       let vars = Vars.of_meta_rules meta.vars in
       let pkg_dir = Vars.get vars "directory" Ps.empty in
-      let dir =
+      let external_location : Dune_package.External_location.t =
         match pkg_dir with
-        | None | Some "" -> dir
+        | None | Some "" -> loc
         | Some pkg_dir ->
           if pkg_dir.[0] = '+' || pkg_dir.[0] = '^'
-          then Path.relative db.stdlib_dir (String.drop pkg_dir 1)
+          then Relative_to_stdlib (Path.Local.of_string (String.drop pkg_dir 1))
           else if Filename.is_relative pkg_dir
-          then Path.relative dir pkg_dir
-          else Path.of_filename_relative_to_initial_cwd pkg_dir
+          then (
+            match loc with
+            | Relative_to_findlib (cur, sub) ->
+              Relative_to_findlib (cur, Path.Local.relative sub pkg_dir)
+            | Absolute path -> Absolute (Path.relative path pkg_dir)
+            | Relative_to_stdlib sub ->
+              Relative_to_stdlib (Path.Local.relative sub pkg_dir))
+          else Absolute (Path.of_filename_relative_to_initial_cwd pkg_dir)
       in
+      let dir = dir_of_loc external_location in
       let pkg : Findlib.Package.t =
         { Findlib.Package.meta_file; name = full_name; dir; vars }
       in
       let* lib =
         let+ dir_contents = Fs.dir_contents pkg.dir in
-        to_dune_library pkg ~dir_contents ~ext_lib:db.ext_lib
+        to_dune_library pkg ~dir_contents ~ext_lib:db.ext_lib ~external_location
       in
       let* (entry : Dune_package.Entry.t) =
         let+ exists =
@@ -300,12 +298,13 @@ module Loader = struct
           | None -> full_name
           | Some name -> Lib_name.nest full_name name
         in
-        loop ~dir ~full_name meta acc)
+        loop ~loc:external_location ~full_name meta acc)
     in
     let name = Option.value_exn meta.name in
     let+ entries =
-      loop ~dir ~full_name:(Option.value_exn meta.name) meta Lib_name.Map.empty
+      loop ~loc ~full_name:(Option.value_exn meta.name) meta Lib_name.Map.empty
     in
+    let dir = dir_of_loc loc in
     { Dune_package.name = Lib_name.package_name name
     ; version =
         (let open Option.O in
@@ -329,25 +328,29 @@ module Loader = struct
   let load_builtin db meta =
     dune_package_of_meta
       db
-      ~dir:db.stdlib_dir
+      ~loc:(Relative_to_stdlib (Path.Local.of_string "."))
       ~meta_file:(Path.of_string "<internal>")
       ~meta
   ;;
 
-  let lookup db name dir : (Dune_package.t, Unavailable_reason.t) result option Memo.t =
-    let load_meta ~dir meta_file =
+  let lookup db name findlib_dir
+    : (Dune_package.t, Unavailable_reason.t) result option Memo.t
+    =
+    let load_meta ~findlib_dir ~dir meta_file =
       load_meta (Some name) meta_file
       >>= function
       | None -> Memo.return None
-      | Some meta -> dune_package_of_meta db ~dir ~meta_file ~meta >>| Option.some
+      | Some meta ->
+        let loc = Dune_package.External_location.Relative_to_findlib (findlib_dir, dir) in
+        dune_package_of_meta db ~loc ~meta_file ~meta >>| Option.some
     in
     (* XXX DUNE4 why do we allow [META.foo] override [dune-package] file? *)
-    Path.relative dir (Findlib.Package.meta_fn ^ "." ^ Package.Name.to_string name)
-    |> load_meta ~dir
+    Path.relative findlib_dir (Findlib.Package.meta_fn ^ "." ^ Package.Name.to_string name)
+    |> load_meta ~findlib_dir ~dir:(Path.Local.of_string ".")
     >>= function
     | Some pkg -> Memo.return (Some (Ok pkg))
     | None ->
-      let dir = Path.relative dir (Package.Name.to_string name) in
+      let dir = Path.relative findlib_dir (Package.Name.to_string name) in
       Fs.dir_exists dir
       >>= (function
        | false -> Memo.return None
@@ -363,7 +366,9 @@ module Loader = struct
           | Ok (Dune_package.Or_meta.Dune_package p) -> Memo.return (Some (Ok p))
           | Ok Use_meta ->
             Path.relative dir Findlib.Package.meta_fn
-            |> load_meta ~dir
+            |> load_meta
+                 ~findlib_dir
+                 ~dir:(Path.Local.of_string (Package.Name.to_string name))
             >>| Option.map ~f:(fun pkg -> Ok pkg)))
   ;;
 

src/dune_rules/gen_rules.ml

@@ -354,6 +354,7 @@ let gen_project_rules =
     let* sctx = sctx in
     let+ () = Install_rules.gen_project_rules sctx project
     and+ () = Odoc.gen_project_rules sctx project
+    and+ () = Odoc_new.gen_project_rules sctx project
     and+ () =
       let version = 2, 8 in
       match Dune_project.allow_approximate_merlin project with
@@ -525,7 +526,8 @@ let gen_rules_regular_directory sctx ~src_dir ~components ~dir =
               | [] ->
                 (* XXX sync this list with the pattern matches above. It's quite ugly
                    we need this, we should rewrite this code to avoid this. *)
-                Filename.Set.of_list [ ".js"; "_doc"; ".ppx"; ".dune"; ".topmod" ]
+                Filename.Set.of_list
+                  [ ".js"; "_doc"; "_doc_new"; ".ppx"; ".dune"; ".topmod" ]
             in
             Filename.Set.union automatic toplevel
           in
@@ -587,6 +589,9 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t =
   | "_doc" :: rest ->
     let* sctx = sctx in
     Odoc.gen_rules sctx rest ~dir
+  | "_doc_new" :: rest ->
+    let* sctx = sctx in
+    Odoc_new.gen_rules sctx rest ~dir
   | ".topmod" :: comps ->
     has_rules
       ~dir