Private libraries attached to a package

CHANGES.md

@@ -40,6 +40,10 @@ Unreleased
 - Fix cram tests inside vendored directories not being interpreted correctly.
   (@rgrinberg, #3860)
 
+- Add `package` field to private libraries. This allows such libraries to be
+  installed and to be usable by other public libraries in the same project
+  (#3655, fixes #1017, @rgrinberg)
+
 2.7.1 (2/09/2020)
 -----------------
 

doc/dune-files.rst

@@ -356,6 +356,12 @@ to use the :ref:`include_subdirs` stanza.
   want. The package name must be one of the packages that dune knows about,
   as determined by the :ref:`opam-files`
 
+- ``(package <package>)`` Install private library under the specified package.
+  Such a library is now usable by public libraries defined in the same project.
+  The findlib name for this library will be ``<package>.__private__.<name>``,
+  however the library's interface will be hidden from consumers outside the
+  project.
+
 - ``(synopsis <string>)`` should give a one-line description of the library.
   This is used by tools that list installed libraries
 

src/dune_engine/lib_name.ml

@@ -1,5 +1,7 @@
 open Stdune
 
+let private_key = "__private__"
+
 module Local = struct
   type t = string
 
@@ -67,6 +69,9 @@ module Local = struct
             loop false 0
     end) :
       Stringlike_intf.S with type t := t )
+
+  let mangled_path_under_package local_name =
+    [ private_key; to_string local_name ]
 end
 
 let split t =
@@ -76,6 +81,13 @@ let split t =
 
 let to_local = Local.of_string_user_error
 
+let to_local_exn t =
+  match Local.of_string_opt t with
+  | Some s -> s
+  | None ->
+    Code_error.raise "invalid Lib_name.t -> Lib_name.Local.t conversion"
+      [ ("t", String t) ]
+
 include Stringlike.Make (struct
   type nonrec t = string
 
@@ -95,6 +107,20 @@ include Stringlike.Make (struct
     | s -> Option.some_if (s.[0] <> '.') s
 end)
 
+type analyze =
+  | Public of Package.Name.t * string list
+  | Private of Package.Name.t * Local.t
+
+let analyze t =
+  let pkg, rest = split t in
+  match rest with
+  | [ pkey; name ] when pkey = private_key -> Private (pkg, Local.of_string name)
+  | _ -> Public (pkg, rest)
+
+let mangled pkg local_name =
+  let under_pkg = Local.mangled_path_under_package local_name in
+  Package.Name.to_string pkg :: under_pkg |> String.concat ~sep:"." |> of_string
+
 let of_local (_loc, t) = t
 
 let of_package_name p = Package.Name.to_string p

src/dune_engine/lib_name.mli

@@ -11,6 +11,8 @@ module Local : sig
 
   (** Description of valid library names *)
   val valid_format_doc : User_message.Style.t Pp.t
+
+  val mangled_path_under_package : t -> string list
 end
 
 val compare : t -> t -> Ordering.t
@@ -21,12 +23,22 @@ val of_local : Loc.t * Local.t -> t
 
 val to_local : Loc.t * t -> (Local.t, User_message.t) result
 
+val to_local_exn : t -> Local.t
+
 val split : t -> Package.Name.t * string list
 
 val package_name : t -> Package.Name.t
 
 val of_package_name : Package.Name.t -> t
 
+type analyze =
+  | Public of Package.Name.t * string list
+  | Private of Package.Name.t * Local.t
+
+val analyze : t -> analyze
+
+val mangled : Package.Name.t -> Local.t -> t
+
 module Map : Map.S with type key = t
 
 module Set : sig

src/dune_rules/compilation_context.ml

@@ -6,12 +6,12 @@ module SC = Super_context
 module Includes = struct
   type t = Command.Args.dynamic Command.Args.t Cm_kind.Dict.t
 
-  let make ~opaque ~requires : _ Cm_kind.Dict.t =
+  let make ~project ~opaque ~requires : _ Cm_kind.Dict.t =
     match requires with
     | Error exn ->
       Cm_kind.Dict.make_all (Command.Args.Fail { fail = (fun () -> raise exn) })
     | Ok libs ->
-      let iflags = Lib.L.include_flags libs in
+      let iflags = Lib.L.include_flags ~project libs in
       let cmi_includes =
         Command.Args.memo
           (Command.Args.S
@@ -118,8 +118,9 @@ let create ~super_context ~scope ~expander ~obj_dir ~modules ~flags
     ~requires_compile ~requires_link ?(preprocessing = Preprocessing.dummy)
     ~opaque ?stdlib ~js_of_ocaml ~dynlink ~package ?vimpl ?modes
     ?(bin_annot = true) () =
+  let project = Scope.project scope in
   let requires_compile =
-    if Dune_project.implicit_transitive_deps (Scope.project scope) then
+    if Dune_project.implicit_transitive_deps project then
       Lazy.force requires_link
     else
       requires_compile
@@ -146,7 +147,7 @@ let create ~super_context ~scope ~expander ~obj_dir ~modules ~flags
   ; flags
   ; requires_compile
   ; requires_link
-  ; includes = Includes.make ~opaque ~requires:requires_compile
+  ; includes = Includes.make ~project ~opaque ~requires:requires_compile
   ; preprocessing
   ; opaque
   ; stdlib

src/dune_rules/dune_file.ml

@@ -507,7 +507,7 @@ module Library = struct
 
   type visibility =
     | Public of Public_lib.t
-    | Private
+    | Private of Package.t option
 
   type t =
     { name : Loc.t * Lib_name.Local.t
@@ -609,6 +609,10 @@ module Library = struct
          field_o "instrumentation.backend"
            ( Dune_lang.Syntax.since Stanza.syntax (2, 7)
            >>> fields (field "ppx" (located Lib_name.decode)) )
+       and+ package =
+         field_o "package"
+           ( Dune_lang.Syntax.since Stanza.syntax (2, 8)
+           >>> located Stanza_common.Pkg.decode )
        in
        let wrapped =
          Wrapped.make ~wrapped ~implements ~special_builtin_support
@@ -646,9 +650,17 @@ module Library = struct
              ]
        in
        let visibility =
-         match public with
-         | None -> Private
-         | Some public -> Public public
+         match (public, package) with
+         | None, None -> Private None
+         | Some public, None -> Public public
+         | None, Some (_loc, package) -> Private (Some package)
+         | Some public, Some (loc, _) ->
+           User_error.raise ~loc
+             [ Pp.textf
+                 "This library has a pullic_name, it already belongs to the \
+                  package %s"
+                 (Package.Name.to_string public.package.name)
+             ]
        in
        Option.both virtual_modules implements
        |> Option.iter ~f:(fun (virtual_modules, (_, impl)) ->
@@ -694,12 +706,15 @@ module Library = struct
   let package t =
     match t.visibility with
     | Public p -> Some p.package
-    | Private -> None
+    | Private p -> p
 
   let sub_dir t =
     match t.visibility with
     | Public p -> p.sub_dir
-    | Private -> None
+    | Private None -> None
+    | Private (Some _) ->
+      Lib_name.Local.mangled_path_under_package (snd t.name)
+      |> String.concat ~sep:"/" |> Option.some
 
   let has_foreign t = Buildable.has_foreign t.buildable
 
@@ -723,17 +738,24 @@ module Library = struct
 
   let best_name t =
     match t.visibility with
-    | Private -> Lib_name.of_local t.name
+    | Private _ -> Lib_name.of_local t.name
     | Public p -> snd p.name
 
   let is_virtual t = Option.is_some t.virtual_modules
 
   let is_impl t = Option.is_some t.implements
 
   let obj_dir ~dir t =
+    let private_lib =
+      match t.visibility with
+      | Private (Some _) -> true
+      | Private None
+      | Public _ ->
+        false
+    in
     Obj_dir.make_lib ~dir
       ~has_private_modules:(t.private_modules <> None)
-      (snd t.name)
+      ~private_lib (snd t.name)
 
   let main_module_name t : Lib_info.Main_module_name.t =
     match (t.implements, t.wrapped) with
@@ -772,7 +794,7 @@ module Library = struct
     in
     let status =
       match conf.visibility with
-      | Private -> Lib_info.Status.Private conf.project
+      | Private pkg -> Lib_info.Status.Private (conf.project, pkg)
       | Public p -> Public (conf.project, p.package)
     in
     let virtual_library = is_virtual conf in
@@ -835,6 +857,7 @@ module Library = struct
     let version =
       match status with
       | Public (_, pkg) -> pkg.version
+      | Installed_private
       | Installed
       | Private _ ->
         None
@@ -1895,22 +1918,31 @@ module Library_redirect = struct
   module Local = struct
     type nonrec t = (Loc.t * Lib_name.Local.t) t
 
+    let for_lib (lib : Library.t) ~new_public_name ~loc : t =
+      { loc; new_public_name; old_name = lib.name; project = lib.project }
+
+    let of_private_lib (lib : Library.t) : t option =
+      match lib.visibility with
+      | Public _
+      | Private None ->
+        None
+      | Private (Some package) ->
+        let loc, name = lib.name in
+        let new_public_name = (loc, Lib_name.mangled package.name name) in
+        Some (for_lib lib ~loc ~new_public_name)
+
     let of_lib (lib : Library.t) : t option =
       let open Option.O in
-      let* public =
+      let* public_name =
         match lib.visibility with
-        | Public p -> Some p
-        | Private -> None
+        | Public plib -> Some plib.name
+        | Private _ -> None
       in
-      if Lib_name.equal (Lib_name.of_local lib.name) (snd public.name) then
+      if Lib_name.equal (Lib_name.of_local lib.name) (snd public_name) then
         None
       else
-        Some
-          { loc = Loc.none
-          ; project = lib.project
-          ; old_name = lib.name
-          ; new_public_name = public.name
-          }
+        let loc = fst public_name in
+        Some (for_lib lib ~loc ~new_public_name:public_name)
   end
 end
 

src/dune_rules/dune_file.mli

@@ -114,7 +114,7 @@ end
 module Library : sig
   type visibility =
     | Public of Public_lib.t
-    | Private
+    | Private of Package.t option
 
   type t =
     { name : Loc.t * Lib_name.Local.t
@@ -365,6 +365,8 @@ module Library_redirect : sig
 
   module Local : sig
     type nonrec t = (Loc.t * Lib_name.Local.t) t
+
+    val of_private_lib : Library.t -> t option
   end
 end
 

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 Lib_name.analyze name with
+           | Private (_, _) -> Lib_info.Status.Installed_private
+           | Public (_, _) -> 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 Lib_name.analyze t.name with
+          | Private (_, _) -> Lib_info.Status.Installed_private
+          | Public (_, _) -> 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/gen_meta.ml

@@ -8,9 +8,7 @@ module Pub_name = struct
     | Dot of t * string
     | Id of string
 
-  let parse s =
-    let s = Lib_name.to_string s in
-    match String.split s ~on:'.' with
+  let of_list = function
     | [] -> assert false
     | x :: l ->
       let rec loop acc l =
@@ -20,6 +18,10 @@ module Pub_name = struct
       in
       loop (Id x) l
 
+  let of_lib_name s =
+    let pkg, xs = Lib_name.split s in
+    of_list (Package.Name.to_string pkg :: xs)
+
   let rec root = function
     | Dot (t, _) -> root t
     | Id n -> n
@@ -157,18 +159,39 @@ let gen ~(package : Package.t) ~add_directory_entry entries =
     List.map entries ~f:(fun (e : Super_context.Lib_entry.t) ->
         match e with
         | Library lib -> (
-          let name = Lib.Local.info lib |> Lib_info.name in
-          let pub_name = Pub_name.parse name in
+          let info = Lib.Local.info lib in
+          let pub_name =
+            let name = Lib_info.name info in
+            Pub_name.of_lib_name name
+          in
           match Pub_name.to_list pub_name with
           | [] -> assert false
-          | _package :: path ->
+          | package :: path ->
+            let pub_name, path =
+              match Lib_info.status info with
+              | Private (_, None) ->
+                (* Not possible b/c we wouldn't be generating a META file for a
+                   private library without a package. *)
+                assert false
+              | Private (_, Some pkg) ->
+                assert (path = []);
+                let path =
+                  Lib_name.Local.mangled_path_under_package
+                    (Lib_name.Local.of_string package)
+                in
+                let pub_name =
+                  Pub_name.of_list (Package.Name.to_string pkg.name :: path)
+                in
+                (pub_name, path)
+              | _ -> (pub_name, path)
+            in
             (pub_name, gen_lib pub_name ~path (Lib.Local.to_lib lib) ~version) )
         | Deprecated_library_name
             { old_name = old_public_name, _
             ; new_public_name = _, new_public_name
             ; _
             } ->
-          ( Pub_name.parse (Dune_file.Public_lib.name old_public_name)
+          ( Pub_name.of_lib_name (Dune_file.Public_lib.name old_public_name)
           , version @ [ requires (Lib_name.Set.singleton new_public_name) ] ))
   in
   let pkgs =