Hide cmi dir of package private libraries

Signed-off-by: Rudi Grinberg <[email protected]>

src/dune_rules/dune_file.ml

@@ -825,6 +825,7 @@ module Library = struct
     let version =
       match status with
       | Public (_, pkg) -> pkg.version
+      | Installed_private
       | Installed
       | Private _ ->
         None

src/dune_rules/dune_package.ml

@@ -156,7 +156,11 @@ module Lib = struct
        let info : Path.t Lib_info.t =
          let src_dir = Obj_dir.dir obj_dir in
          let enabled = Lib_info.Enabled_status.Normal in
-         let status = Lib_info.Status.Installed in
+         let status =
+           match snd (Lib_name.split name) with
+           | [ "__private__"; _ ] -> Lib_info.Status.Installed_private
+           | _ -> Lib_info.Status.Installed
+         in
          let version = None in
          let main_module_name = Lib_info.Inherited.This main_module_name in
          let foreign_objects = Lib_info.Source.External foreign_objects in

src/dune_rules/findlib/findlib.ml

@@ -297,7 +297,11 @@ end = struct
         let kind = kind t in
         let sub_systems = Sub_system_name.Map.empty in
         let synopsis = description t in
-        let status = Lib_info.Status.Installed in
+        let status =
+          match snd (Lib_name.split t.name) with
+          | [ "__private__"; _ ] -> Lib_info.Status.Installed_private
+          | _ -> Lib_info.Status.Installed
+        in
         let src_dir = Obj_dir.dir obj_dir in
         let version = version t in
         let dune_version = None in

src/dune_rules/lib.ml

@@ -246,6 +246,7 @@ module T = struct
     ; user_written_deps : Dune_file.Lib_deps.t
     ; implements : t Or_exn.t option
     ; lib_config : Lib_config.t
+    ; project : Dune_project.t option
     ; (* these fields cannot be forced until the library is instantiated *)
       default_implementation : t Or_exn.t Lazy.t option
     ; (* This is mutable to avoid this error:
@@ -320,14 +321,17 @@ type db =
   ; all : Lib_name.t list Lazy.t
   ; lib_config : Lib_config.t
   ; instrument_with : Lib_name.t list
+  ; find_project : Package.Name.t -> Dune_project.t option
   }
 
 and resolve_result =
   | Not_found
   | Found of Lib_info.external_
   | Hidden of Lib_info.external_ Hidden.t
   | Invalid of exn
-  | Redirect of db option * (Loc.t * Lib_name.t)
+  | (* Redirect (None, lib) looks up lib in the same database *)
+      Redirect of
+      db option * (Loc.t * Lib_name.t)
 
 let lib_config (t : lib) = t.lib_config
 
@@ -467,9 +471,16 @@ module L = struct
       match project with
       | None -> fun _ -> true
       | Some project -> (
+        let check_project lib =
+          match lib.project with
+          | None -> false
+          | Some project' -> Dune_project.equal project project'
+        in
         fun lib ->
           match Lib_info.status lib.info with
-          | Private (project', Some _) -> Dune_project.equal project project'
+          | Private (_, Some _)
+          | Installed_private ->
+            check_project lib
           | _ -> true )
     in
     let dirs =
@@ -1016,6 +1027,7 @@ end = struct
     let status = Lib_info.status info in
     let allow_private_deps =
       match status with
+      | Installed_private
       | Private _
       | Installed ->
         Allow_all
@@ -1108,6 +1120,11 @@ end = struct
     in
     let requires = map_error requires in
     let ppx_runtime_deps = map_error ppx_runtime_deps in
+    let project =
+      let open Option.O in
+      let* package = Lib_info.package info in
+      db.find_project package
+    in
     let t =
       { info
       ; name
@@ -1122,6 +1139,7 @@ end = struct
       ; default_implementation
       ; lib_config = db.lib_config
       ; re_exports
+      ; project
       }
     in
     t.sub_systems <-
@@ -1677,13 +1695,14 @@ module DB = struct
 
   (* CR-soon amokhov: this whole module should be rewritten using the
      memoization framework instead of using mutable state. *)
-  let create ~parent ~resolve ~all ~lib_config () =
+  let create ~parent ~resolve ~find_project ~all ~lib_config () =
     { parent
     ; resolve
     ; table = Table.create (module Lib_name) 1024
     ; all = Lazy.from_fun all
     ; lib_config
     ; instrument_with = lib_config.Lib_config.instrument_with
+    ; find_project
     }
 
   module Library_related_stanza = struct
@@ -1716,7 +1735,7 @@ module DB = struct
     let found x = Found x
   end
 
-  let create_from_stanzas ~parent ~lib_config stanzas =
+  let create_from_stanzas ~parent ~find_project ~lib_config stanzas =
     let map : Found_or_redirect.t Lib_name.Map.t =
       List.concat_map stanzas ~f:(fun stanza ->
           match (stanza : Library_related_stanza.t) with
@@ -1773,7 +1792,7 @@ module DB = struct
                  ; Pp.textf "- %s" (Loc.to_file_colon_line loc2)
                  ])
     in
-    create () ~parent
+    create () ~parent ~find_project
       ~resolve:(fun name ->
         match Lib_name.Map.find map name with
         | None -> Not_found
@@ -1782,8 +1801,8 @@ module DB = struct
       ~all:(fun () -> Lib_name.Map.keys map)
       ~lib_config
 
-  let create_from_findlib ~lib_config findlib =
-    create () ~parent:None ~lib_config
+  let create_from_findlib ~lib_config ~find_project findlib =
+    create () ~parent:None ~lib_config ~find_project
       ~resolve:(fun name ->
         match Findlib.find findlib name with
         | Ok (Library pkg) -> Found (Dune_package.Lib.info pkg)

src/dune_rules/lib.mli

@@ -172,6 +172,7 @@ module DB : sig
   val create :
        parent:t option
     -> resolve:(Lib_name.t -> Resolve_result.t)
+    -> find_project:(Package.Name.t -> Dune_project.t option)
     -> all:(unit -> Lib_name.t list)
     -> lib_config:Lib_config.t
     -> unit
@@ -187,11 +188,16 @@ module DB : sig
   (** Create a database from a list of library stanzas *)
   val create_from_stanzas :
        parent:t option
+    -> find_project:(Package.Name.t -> Dune_project.t option)
     -> lib_config:Lib_config.t
     -> Library_related_stanza.t list
     -> t
 
-  val create_from_findlib : lib_config:Lib_config.t -> Findlib.t -> t
+  val create_from_findlib :
+       lib_config:Lib_config.t
+    -> find_project:(Package.Name.t -> Dune_project.t option)
+    -> Findlib.t
+    -> t
 
   val find : t -> Lib_name.t -> lib option
 

src/dune_rules/lib_info.ml

@@ -176,13 +176,15 @@ end
 
 module Status = struct
   type t =
+    | Installed_private
     | Installed
     | Public of Dune_project.t * Package.t
     | Private of Dune_project.t * Package.t option
 
   let to_dyn x =
     let open Dyn.Encoder in
     match x with
+    | Installed_private -> constr "Installed_private" []
     | Installed -> constr "Installed" []
     | Public (name, package) ->
       constr "Public" [ Dune_project.to_dyn name; Package.to_dyn package ]
@@ -191,13 +193,18 @@ module Status = struct
         [ Dune_project.to_dyn proj; option Package.to_dyn package ]
 
   let is_private = function
-    | Private _ -> true
+    | Installed_private
+    | Private _ ->
+      true
     | Installed
     | Public _ ->
       false
 
   let project_name = function
-    | Installed -> None
+    | Installed_private
+    (* TODO this isn't right *)
+    | Installed ->
+      None
     | Private (project, _)
     | Public (project, _) ->
       Some (Dune_project.name project)
@@ -527,6 +534,8 @@ let to_dyn path
 
 let package t =
   match t.status with
-  | Installed -> Some (Lib_name.package_name t.name)
+  | Installed_private
+  | Installed ->
+    Some (Lib_name.package_name t.name)
   | Public (_, p) -> Some p.name
-  | Private _ -> None
+  | Private (_, p) -> Option.map p ~f:(fun t -> t.name)

src/dune_rules/lib_info.mli

@@ -11,6 +11,7 @@ open Stdune
 
 module Status : sig
   type t =
+    | Installed_private
     | Installed
     | Public of Dune_project.t * Package.t
     | Private of Dune_project.t * Package.t option

src/dune_rules/link_time_code_gen.ml

@@ -135,7 +135,9 @@ let build_info_code cctx ~libs ~api_version =
           | Some v -> sprintf "Some %S" v
           | None -> (
             match Lib_info.status (Lib.info lib) with
-            | Installed -> "None"
+            | Installed_private
+            | Installed ->
+              "None"
             | Public (_, p) -> version_of_package p
             | Private _ ->
               let p =

src/dune_rules/odoc.ml

@@ -35,7 +35,9 @@ let lib_unique_name lib =
   let info = Lib.info lib in
   let status = Lib_info.status info in
   match status with
-  | Installed -> assert false
+  | Installed_private
+  | Installed ->
+    assert false
   | Public _ -> Lib_name.to_string name
   | Private (project, _) -> Scope_key.to_string name project
 

src/dune_rules/preprocessing.ml

@@ -61,6 +61,7 @@ end = struct
               let status = Lib_info.status info in
               match status with
               | Private (scope_name, _) -> Some scope_name
+              | Installed_private
               | Public _
               | Installed ->
                 None

src/dune_rules/scope.ml

@@ -53,7 +53,7 @@ module DB = struct
     | Some (Name name) -> Lib.DB.Resolve_result.redirect None name
 
   (* Create a database from the public libraries defined in the stanzas *)
-  let public_libs t ~installed_libs ~lib_config stanzas =
+  let public_libs t ~installed_libs ~lib_config ~find_project stanzas =
     let public_libs =
       List.filter_map stanzas
         ~f:(fun (stanza : Lib.DB.Library_related_stanza.t) ->
@@ -96,11 +96,12 @@ module DB = struct
             ] )
     in
     let resolve = resolve t public_libs in
-    Lib.DB.create ~parent:(Some installed_libs) ~resolve
+    Lib.DB.create ~parent:(Some installed_libs) ~resolve ~find_project
       ~all:(fun () -> Lib_name.Map.keys public_libs)
       ~lib_config ()
 
-  let scopes_by_dir context ~projects ~public_libs stanzas coq_stanzas =
+  let scopes_by_dir context ~projects ~find_project ~public_libs stanzas
+      coq_stanzas =
     let projects_by_dir =
       List.map projects ~f:(fun (project : Dune_project.t) ->
           (Dune_project.root project, project))
@@ -137,22 +138,24 @@ module DB = struct
         let stanzas, coq_stanzas = Option.value stanzas ~default:([], []) in
         let db =
           Lib.DB.create_from_stanzas stanzas ~parent:(Some public_libs)
-            ~lib_config
+            ~find_project ~lib_config
         in
         let coq_db = Coq_lib.DB.create_from_coqlib_stanzas coq_stanzas in
         let root =
           Path.Build.append_source context.build_dir (Dune_project.root project)
         in
         Some { project; db; coq_db; root })
 
-  let create ~projects ~context ~installed_libs stanzas coq_stanzas =
+  let create ~projects ~context ~installed_libs ~find_project stanzas
+      coq_stanzas =
     let t = Fdecl.create Dyn.Encoder.opaque in
     let public_libs =
       let lib_config = Context.lib_config context in
-      public_libs t ~installed_libs ~lib_config stanzas
+      public_libs t ~installed_libs ~lib_config ~find_project stanzas
     in
     let by_dir =
-      scopes_by_dir context ~projects ~public_libs stanzas coq_stanzas
+      scopes_by_dir context ~projects ~find_project ~public_libs stanzas
+        coq_stanzas
     in
     let value = { by_dir } in
     Fdecl.set t value;
@@ -164,7 +167,8 @@ module DB = struct
         [ ("dir", Path.Build.to_dyn dir) ];
     find_by_dir t (Path.Build.drop_build_context_exn dir)
 
-  let create_from_stanzas ~projects ~context ~installed_libs stanzas =
+  let create_from_stanzas ~projects ~find_project ~context ~installed_libs
+      stanzas =
     let stanzas, coq_stanzas =
       Dune_load.Dune_file.fold_stanzas stanzas ~init:([], [])
         ~f:(fun dune_file stanza (acc, coq_acc) ->
@@ -185,5 +189,5 @@ module DB = struct
             (acc, (ctx_dir, coq_lib) :: coq_acc)
           | _ -> (acc, coq_acc))
     in
-    create ~projects ~context ~installed_libs stanzas coq_stanzas
+    create ~projects ~context ~installed_libs ~find_project stanzas coq_stanzas
 end

src/dune_rules/scope.mli

@@ -25,6 +25,7 @@ module DB : sig
   (** Return the new scope database as well as the public libraries database *)
   val create_from_stanzas :
        projects:Dune_project.t list
+    -> find_project:(Package.Name.t -> Dune_project.t option)
     -> context:Context.t
     -> installed_libs:Lib.DB.t
     -> Dune_load.Dune_file.t list

src/dune_rules/super_context.ml

@@ -486,11 +486,25 @@ let create_lib_entries_by_package ~public_libs stanzas =
          (List.sort ~compare:(fun a b ->
               Lib_name.compare (Lib_entry.name a) (Lib_entry.name b)))
 
+let create_projects_by_package projects : Dune_project.t Package.Name.Map.t =
+  List.concat_map projects ~f:(fun project ->
+      Dune_project.packages project
+      |> Package.Name.Map.values
+      |> List.map ~f:(fun (pkg : Package.t) -> (pkg.name, project)))
+  |> Package.Name.Map.of_list_exn
+
 let create ~(context : Context.t) ?host ~projects ~packages ~stanzas =
   let lib_config = Context.lib_config context in
-  let installed_libs = Lib.DB.create_from_findlib context.findlib ~lib_config in
+  let find_project =
+    let projects_by_package = create_projects_by_package projects in
+    Package.Name.Map.find projects_by_package
+  in
+  let installed_libs =
+    Lib.DB.create_from_findlib context.findlib ~lib_config ~find_project
+  in
   let scopes, public_libs =
-    Scope.DB.create_from_stanzas ~projects ~context ~installed_libs stanzas
+    Scope.DB.create_from_stanzas ~projects ~find_project ~context
+      ~installed_libs stanzas
   in
   let stanzas =
     List.map stanzas ~f:(fun { Dune_load.Dune_file.dir; project; stanzas } ->