Private Modules (#1241)

Add private_modules field

This field specifies modules that can only be used by the current library. As a consequence, their objects are stored separately (not to leak as includes to other libs) and their cmi's aren't installed.

CHANGES.md

@@ -59,6 +59,9 @@ next
 - Test stanzas take an optional (action) field to customize how they run (#1248,
   #1195, @emillon)
 
+- Add support for private modules via the `private_modules` field (#1241, fix
+  #427, @rgrinberg)
+
 1.1.1 (08/08/2018)
 ------------------
 

doc/dune-files.rst

@@ -190,6 +190,10 @@ to use the :ref:`include_subdirs` stanza.
   such modules to avoid surprises. ``<modules>`` must be a subset of
   the modules listed in the ``(modules ...)`` field.
 
+- ``(private_modules <modules>)`` species a list of modules that will be marked
+  as private. Private modules are inaccessible from outside the libraries they
+  are defined in.
+
 - ``(allow_overlapping_dependencies)`` allows external dependencies to
   overlap with libraries that are present in the workspace
 

src/compilation_context.ml

@@ -50,6 +50,7 @@ type t =
   ; dir                  : Path.t
   ; dir_kind             : File_tree.Dune_file.Kind.t
   ; obj_dir              : Path.t
+  ; private_obj_dir      : Path.t option
   ; modules              : Module.t Module.Name.Map.t
   ; alias_module         : Module.t option
   ; lib_interface_module : Module.t option
@@ -66,6 +67,7 @@ let scope                t = t.scope
 let dir                  t = t.dir
 let dir_kind             t = t.dir_kind
 let obj_dir              t = t.obj_dir
+let private_obj_dir      t = t.private_obj_dir
 let modules              t = t.modules
 let alias_module         t = t.alias_module
 let lib_interface_module t = t.lib_interface_module
@@ -79,14 +81,16 @@ let opaque               t = t.opaque
 let context              t = Super_context.context t.super_context
 
 let create ~super_context ~scope ~dir ?(dir_kind=File_tree.Dune_file.Kind.Dune)
-      ?(obj_dir=dir) ~modules ?alias_module ?lib_interface_module ~flags
-      ~requires ?(preprocessing=Preprocessing.dummy) ?(no_keep_locs=false)
+      ?(obj_dir=dir) ?private_obj_dir ~modules ?alias_module
+      ?lib_interface_module ~flags ~requires ?(preprocessing=Preprocessing.dummy)
+      ?(no_keep_locs=false)
       ~opaque () =
   { super_context
   ; scope
   ; dir
   ; dir_kind
   ; obj_dir
+  ; private_obj_dir
   ; modules
   ; alias_module
   ; lib_interface_module

src/compilation_context.mli

@@ -19,6 +19,7 @@ val create
   -> dir                   : Path.t
   -> ?dir_kind             : File_tree.Dune_file.Kind.t
   -> ?obj_dir              : Path.t
+  -> ?private_obj_dir      : Path.t
   -> modules               : Module.t Module.Name.Map.t
   -> ?alias_module         : Module.t
   -> ?lib_interface_module : Module.t
@@ -39,6 +40,7 @@ val scope                : t -> Scope.t
 val dir                  : t -> Path.t
 val dir_kind             : t -> File_tree.Dune_file.Kind.t
 val obj_dir              : t -> Path.t
+val private_obj_dir      : t -> Path.t option
 val modules              : t -> Module.t Module.Name.Map.t
 val alias_module         : t -> Module.t option
 val lib_interface_module : t -> Module.t option

src/dir_contents.ml

@@ -14,6 +14,7 @@ module Modules_field_evaluator : sig
     :  modules:Module.Name_map.t
     -> buildable:Buildable.t
     -> virtual_modules:Ordered_set_lang.t option
+    -> private_modules:Ordered_set_lang.t
     -> t
 end = struct
   type t =
@@ -55,25 +56,29 @@ end = struct
 
   module Module_errors = struct
     type t =
-      { missing_modules    : (Loc.t * Module.t) list
-      ; missing_intf_only  : (Loc.t * Module.t) list
-      ; virt_intf_overlaps : (Loc.t * Module.t) list
+      { missing_modules      : (Loc.t * Module.t) list
+      ; missing_intf_only    : (Loc.t * Module.t) list
+      ; virt_intf_overlaps   : (Loc.t * Module.t) list
+      ; private_virt_modules : (Loc.t * Module.t) list
       }
 
     let empty =
-      { missing_modules    = []
-      ; missing_intf_only  = []
-      ; virt_intf_overlaps = []
+      { missing_modules      = []
+      ; missing_intf_only    = []
+      ; virt_intf_overlaps   = []
+      ; private_virt_modules = []
       }
 
-    let map { missing_modules ; missing_intf_only ; virt_intf_overlaps } ~f =
+    let map { missing_modules ; missing_intf_only ; virt_intf_overlaps
+            ; private_virt_modules } ~f =
       { missing_modules = f missing_modules
       ; missing_intf_only = f missing_intf_only
       ; virt_intf_overlaps = f virt_intf_overlaps
+      ; private_virt_modules = f private_virt_modules
       }
   end
 
-  let find_errors ~modules ~intf_only ~virtual_modules =
+  let find_errors ~modules ~intf_only ~virtual_modules ~private_modules =
     let missing_modules =
       Module.Name.Map.fold intf_only ~init:[]
         ~f:(fun ((_, (module_ : Module.t)) as module_loc) acc ->
@@ -90,6 +95,10 @@ end = struct
           else if Module.Name.Map.mem intf_only (Module.name module_) then
             { acc with virt_intf_overlaps = module_loc :: acc.virt_intf_overlaps
             }
+          else if Module.Name.Map.mem private_modules (Module.name module_) then
+            { acc with private_virt_modules =
+                         module_loc :: acc.private_virt_modules
+            }
           else
             acc)
     in
@@ -112,12 +121,13 @@ end = struct
     |> Module_errors.map ~f:List.rev
 
   let check_invalid_module_listing ~(buildable : Buildable.t) ~intf_only
-        ~modules ~virtual_modules =
+        ~modules ~virtual_modules ~private_modules =
     let { Module_errors.
           missing_modules
         ; missing_intf_only
         ; virt_intf_overlaps
-        } = find_errors ~modules ~intf_only ~virtual_modules
+        ; private_virt_modules
+        } = find_errors ~modules ~intf_only ~virtual_modules ~private_modules
     in
     let uncapitalized =
       List.map ~f:(fun (_, m) -> Module.name m |> Module.Name.uncapitalize) in
@@ -126,6 +136,14 @@ end = struct
         Module.name m |> Module.Name.to_string |> sprintf "- %s") modules
       |> String.concat ~sep:"\n"
     in
+    begin match private_virt_modules with
+    | [] -> ()
+    | (loc, _) :: _ ->
+      Errors.fail loc
+        "The following modules are declared as virtual and private: \
+        \n%s\nThis is not possible."
+        (line_list private_virt_modules)
+    end;
     begin match virt_intf_overlaps with
     | [] -> ()
     | (loc, _) :: _ ->
@@ -171,7 +189,8 @@ end = struct
     end
 
   let eval ~modules:(all_modules : Module.Name_map.t)
-        ~buildable:(conf : Buildable.t) ~virtual_modules =
+        ~buildable:(conf : Buildable.t) ~virtual_modules
+        ~private_modules =
     let (fake_modules, modules) =
       eval ~standard:all_modules ~all_modules conf.modules in
     let (fake_modules, intf_only) =
@@ -193,14 +212,27 @@ end = struct
         , virtual_modules
         )
     in
+    let (fake_modules, private_modules) =
+      let (fake_modules', private_modules) =
+        eval ~standard:Module.Name.Map.empty ~all_modules private_modules
+      in
+      ( Module.Name.Map.superpose fake_modules' fake_modules
+      , private_modules
+      )
+    in
     Module.Name.Map.iteri fake_modules ~f:(fun m loc ->
       Errors.warn loc "Module %a is excluded but it doesn't exist."
         Module.Name.pp m
     );
     check_invalid_module_listing ~buildable:conf ~intf_only
-      ~modules ~virtual_modules;
+      ~modules ~virtual_modules ~private_modules;
     let drop_locs = Module.Name.Map.map ~f:snd in
-    { all_modules = drop_locs modules
+    { all_modules =
+        Module.Name.Map.map modules ~f:(fun (_, m) ->
+          if Module.Name.Map.mem private_modules (Module.name m) then
+            Module.set_private m
+          else
+            m)
     ; virtual_modules = drop_locs virtual_modules
     }
 end
@@ -247,7 +279,11 @@ end = struct
       | Yes_with_transition _ ->
         ( wrap_modules modules
         , Module.Name.Map.remove modules main_module_name
-          |> Module.Name.Map.map ~f:Module.wrapped_compat
+          |> Module.Name.Map.filter_map ~f:(fun m ->
+            if Module.is_public m then
+              Some (Module.wrapped_compat m)
+            else
+              None)
         )
     in
     let alias_module =
@@ -263,12 +299,14 @@ end = struct
            https://github.com/ocaml/dune/issues/567 *)
         Some
           (Module.make (Module.Name.add_suffix main_module_name "__")
+             ~visibility:Public
              ~impl:(Module.File.make OCaml
                       (Path.relative dir (sprintf "%s__.ml-gen" lib_name)))
              ~obj_name:(lib_name ^ "__"))
       else
         Some
           (Module.make main_module_name
+             ~visibility:Public
              ~impl:(Module.File.make OCaml
                       (Path.relative dir (lib_name ^ ".ml-gen")))
              ~obj_name:lib_name)
@@ -427,7 +465,7 @@ let modules_of_files ~dir ~files =
   let impls = parse_one_set impl_files in
   let intfs = parse_one_set intf_files in
   Module.Name.Map.merge impls intfs ~f:(fun name impl intf ->
-    Some (Module.make name ?impl ?intf))
+    Some (Module.make name ~visibility:Public ?impl ?intf))
 
 let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules =
   let libs, exes =
@@ -438,19 +476,24 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules =
               all_modules = modules
             ; virtual_modules
             } =
-          Modules_field_evaluator.eval ~modules ~buildable:lib.buildable
+          Modules_field_evaluator.eval ~modules
+            ~buildable:lib.buildable
             ~virtual_modules:lib.virtual_modules
+            ~private_modules:lib.private_modules
         in
         Left ( lib
-             , Library_modules.make lib ~dir:d.ctx_dir modules ~virtual_modules)
+             , Library_modules.make lib ~dir:d.ctx_dir modules ~virtual_modules
+             )
       | Executables exes
       | Tests { exes; _} ->
         let { Modules_field_evaluator.
               all_modules = modules
             ; virtual_modules = _
             } =
-          Modules_field_evaluator.eval ~modules ~buildable:exes.buildable
+          Modules_field_evaluator.eval ~modules
+            ~buildable:exes.buildable
             ~virtual_modules:None
+            ~private_modules:Ordered_set_lang.standard
         in
         Right (exes, modules)
       | _ -> Skip)

src/dune_file.ml

@@ -664,6 +664,8 @@ module Lib_deps = struct
      |> Lib_name.Map.of_list_reduce ~f:Lib_deps_info.Kind.merge
 end
 
+let modules_field name = Ordered_set_lang.field name
+
 module Buildable = struct
   type t =
     { loc                      : Loc.t
@@ -680,8 +682,6 @@ module Buildable = struct
     ; allow_overlapping_dependencies : bool
     }
 
-  let modules_field name = Ordered_set_lang.field name
-
   let dparse =
     let%map loc = loc
     and preprocess =
@@ -917,6 +917,7 @@ module Library = struct
     ; dune_version             : Syntax.Version.t
     ; virtual_modules          : Ordered_set_lang.t option
     ; implements               : (Loc.t * Lib_name.t) option
+    ; private_modules          : Ordered_set_lang.t
     }
 
   let dparse =
@@ -959,6 +960,10 @@ module Library = struct
          field_o "implements" (
            Syntax.since Variants.syntax (0, 1)
            >>= fun () -> located Lib_name.dparse)
+       and private_modules =
+         field "private_modules" ~default:Ordered_set_lang.standard (
+           Syntax.since Stanza.syntax (1, 2)
+           >>= fun () -> Ordered_set_lang.dparse)
        in
        let name =
          let open Syntax.Version.Infix in
@@ -1029,6 +1034,7 @@ module Library = struct
        ; dune_version
        ; virtual_modules
        ; implements
+       ; private_modules
        })
 
   let has_stubs t =

src/dune_file.mli

@@ -251,6 +251,7 @@ module Library : sig
     ; dune_version             : Syntax.Version.t
     ; virtual_modules          : Ordered_set_lang.t option
     ; implements               : (Loc.t * Lib_name.t) option
+    ; private_modules          : Ordered_set_lang.t
     }
 
   val has_stubs : t -> bool

src/inline_tests.ml

@@ -173,6 +173,7 @@ include Sub_system.Register_end_point(
              ~impl:{ path   = Path.relative inline_test_dir main_module_filename
                    ; syntax = OCaml
                    }
+             ~visibility:Public
              ~obj_name:name)
       in
 

src/install_rules.ml

@@ -161,7 +161,8 @@ module Gen(P : Params) = struct
       List.concat
         [ List.concat_map modules ~f:(fun m ->
             List.concat
-              [ [ Module.cm_file_unsafe m ~obj_dir Cmi ]
+              [ if_ (Module.is_public m)
+                  [ Module.cm_file_unsafe m ~obj_dir Cmi ]
               ; if_ (native && Module.has_impl m)
                   [ Module.cm_file_unsafe m ~obj_dir Cmx ]
               ; if_ (native && Module.has_impl m && virtual_library)
@@ -171,7 +172,8 @@ module Gen(P : Params) = struct
                   | None -> None
                   | Some f -> Some f.path)
               ])
-        ; if_ (byte && not virtual_library) [ Library.archive ~dir lib ~ext:".cma" ]
+        ; if_ (byte && not virtual_library)
+            [ Library.archive ~dir lib ~ext:".cma" ]
         ; if virtual_library then (
             (lib.c_names @ lib.cxx_names)
             |> List.map ~f:(fun (_, c) -> Path.relative dir (c ^ ext_obj))

src/lib_rules.ml

@@ -346,6 +346,7 @@ module Gen (P : Install_rules.Params) = struct
   let library_rules (lib : Library.t) ~dir_contents ~dir ~scope
         ~compile_info ~dir_kind =
     let obj_dir = Utils.library_object_directory ~dir lib.name in
+    let private_obj_dir = Utils.library_private_obj_dir ~obj_dir in
     let requires = Lib.Compile.requires compile_info in
     let dep_kind =
       if lib.optional then Lib_deps_info.Kind.Optional else Required
@@ -395,6 +396,7 @@ module Gen (P : Install_rules.Params) = struct
         ~dir
         ~dir_kind
         ~obj_dir
+        ~private_obj_dir
         ~modules
         ?alias_module
         ?lib_interface_module
@@ -453,7 +455,8 @@ module Gen (P : Install_rules.Params) = struct
             ~modules)));
       (* Build *.cma.js *)
       SC.add_rules sctx (
-        let src = Library.archive lib ~dir ~ext:(Mode.compiled_lib_ext Mode.Byte) in
+        let src =
+          Library.archive lib ~dir ~ext:(Mode.compiled_lib_ext Mode.Byte) in
         let target = Path.extend_basename src ~suffix:".js" in
         Js_of_ocaml_rules.build_cm cctx ~js_of_ocaml ~src ~target);
 

src/link_time_code_gen.ml

@@ -40,7 +40,7 @@ let libraries_link ~name ~mode cctx libs =
     SC.add_rule sctx (Build.write_file ml s);
     let impl = Module.File.make OCaml ml in
     let name = Module.Name.of_string basename in
-    let module_ = Module.make ~impl name in
+    let module_ = Module.make ~impl name ~visibility:Public in
     let cctx = Compilation_context.(
       create
         ~super_context:sctx