Relax restriction on project names being unique

CHANGES.md

@@ -81,6 +81,9 @@
   not distinguished in the names of binding operators (`let@` was the
   same as `let&`) (#2376, @aalekseyev, @diml)
 
+- Workspaces with non unique project names are now supported. (#2377, fix #2325,
+  @rgrinberg)
+
 1.10.0 (04/06/2019)
 -------------------
 

src/dune_project.ml

@@ -173,6 +173,19 @@ module Source_kind = struct
       ]
 end
 
+module File_key = struct
+  type t = string
+
+  module Map = String.Map
+
+  let of_string s = s
+  let to_string s = s
+
+  let make ~name ~root =
+    let digest = Digest.generic (name, root) |> Digest.to_string in
+    String.take digest 12
+end
+
 type t =
   { name            : Name.t
   ; root            : Path.Source.t
@@ -194,6 +207,7 @@ type t =
   ; dune_version    : Syntax.Version.t
   ; allow_approx_merlin : bool
   ; generate_opam_files : bool
+  ; file_key : File_key.t
   }
 
 let equal = (==)
@@ -212,6 +226,7 @@ let name t = t.name
 let root t = t.root
 let stanza_parser t = t.stanza_parser
 let file t = t.project_file.file
+let file_key t = t.file_key
 let implicit_transitive_deps t = t.implicit_transitive_deps
 let allow_approx_merlin t = t.allow_approx_merlin
 let generate_opam_files t = t.generate_opam_files
@@ -222,7 +237,8 @@ let to_dyn
       ; bug_reports ; maintainers
       ; extension_args = _; stanza_parser = _ ; packages
       ; implicit_transitive_deps ; wrapped_executables ; dune_version
-      ; allow_approx_merlin ; generate_opam_files } =
+      ; allow_approx_merlin ; generate_opam_files
+      ; file_key } =
   let open Dyn.Encoder in
   record
     [ "name", Name.to_dyn name
@@ -245,6 +261,7 @@ let to_dyn
     ; "dune_version", Syntax.Version.to_dyn dune_version
     ; "allow_approx_merlin", bool allow_approx_merlin
     ; "generate_opam_files", bool generate_opam_files
+    ; "file_key", string file_key
     ]
 
 let find_extension_args t key =
@@ -525,9 +542,11 @@ let anonymous = lazy (
   in
   let implicit_transitive_deps = implicit_transitive_deps_default ~lang in
   let wrapped_executables = wrapped_executables_default ~lang in
-  { name          = name
+  let root = Path.Source.root in
+  let file_key = File_key.make ~root ~name in
+  { name
   ; packages      = Package.Name.Map.empty
-  ; root          = Path.Source.root
+  ; root
   ; source        = None
   ; license       = None
   ; homepage      = None
@@ -545,6 +564,7 @@ let anonymous = lazy (
   ; dune_version = lang.version
   ; allow_approx_merlin = true
   ; generate_opam_files = false
+  ; file_key
   })
 
 let default_name ~dir ~packages =
@@ -694,8 +714,11 @@ let parse ~dir ~lang ~opam_packages ~file =
        Option.value ~default:false allow_approx_merlin in
      let generate_opam_files =
        Option.value ~default:false generate_opam_files in
+     let root = dir in
+     let file_key = File_key.make ~name ~root in
      { name
-     ; root = dir
+     ; file_key
+     ; root
      ; version
      ; source
      ; license
@@ -735,10 +758,13 @@ let make_jbuilder_project ~dir opam_packages =
     }
   in
   let parsing_context, stanza_parser, extension_args =
-    interpret_lang_and_extensions ~lang ~explicit_extensions:[] ~project_file
+    interpret_lang_and_extensions ~lang ~explicit_extensions:[] ~project_file in
+  let root = dir in
+  let file_key = File_key.make ~root ~name
   in
   { name
-  ; root = dir
+  ; root
+  ; file_key
   ; version = None
   ; source = None
   ; license = None

src/dune_project.mli

@@ -52,8 +52,22 @@ end
 
 type t
 
+module File_key : sig
+  (** File_key encodes the project in a unique way to be used as part of file
+      path. *)
+  type t
+
+  val to_string : t -> string
+
+  val of_string : string -> t
+
+  module Map : Map.S with type key = t
+end
+
 val to_dyn : t -> Dyn.t
 
+val file_key : t -> File_key.t
+
 val packages : t -> Package.t Package.Name.Map.t
 val version : t -> string option
 val name : t -> Name.t

src/lib_info.ml

@@ -4,14 +4,15 @@ module Status = struct
   type t =
     | Installed
     | Public  of Dune_project.Name.t * Package.t
-    | Private of Dune_project.Name.t
+    | Private of Dune_project.t
 
   let pp ppf t =
     Format.pp_print_string ppf
       (match t with
        | Installed -> "installed"
        | Public _ -> "public"
-       | Private name ->
+       | Private project ->
+         let name = Dune_project.name project in
          sprintf "private (%s)" (Dune_project.Name.to_string_hum name))
 
   let is_private = function
@@ -20,7 +21,8 @@ module Status = struct
 
   let project_name = function
     | Installed -> None
-    | Public (name, _) | Private name -> Some name
+    | Private project -> Some (Dune_project.name project)
+    | Public (name, _)  -> Some name
 end
 
 
@@ -151,7 +153,7 @@ let of_library_stanza ~dir
   in
   let status =
     match conf.public with
-    | None   -> Status.Private (Dune_project.name conf.project)
+    | None   -> Status.Private conf.project
     | Some p -> Public (Dune_project.name conf.project, p.package)
   in
   let virtual_library = Dune_file.Library.is_virtual conf in

src/lib_info.mli

@@ -13,7 +13,7 @@ module Status : sig
   type t =
     | Installed
     | Public  of Dune_project.Name.t * Package.t
-    | Private of Dune_project.Name.t
+    | Private of Dune_project.t
 
   val pp : t Fmt.t
 

src/odoc.ml

@@ -7,15 +7,41 @@ module SC = Super_context
 
 let (++) = Path.Build.relative
 
+module Scope_key : sig
+  val of_string : Super_context.t -> string -> Lib_name.t * Lib.DB.t
+
+  val to_string : Lib_name.t -> Dune_project.t -> string
+end = struct
+  let of_string sctx s =
+    match String.rsplit2 s ~on:'@' with
+    | None ->
+      ( Lib_name.of_string_exn s ~loc:None
+      , Super_context.public_libs sctx
+      )
+    | Some (lib, key) ->
+      let scope =
+        Dune_project.File_key.of_string key
+        |> Super_context.find_project_by_key sctx
+        |> Super_context.find_scope_by_project sctx
+      in
+      ( Lib_name.of_string_exn lib ~loc:None
+      , Scope.libs scope
+      )
+
+  let to_string lib project =
+    let key = Dune_project.file_key project in
+    sprintf "%s@%s" (Lib_name.to_string lib)
+      (Dune_project.File_key.to_string key)
+end
+
 let lib_unique_name lib =
   let name = Lib.name lib in
   let info = Lib.info lib in
   let status = Lib_info.status info in
   match status with
   | Installed -> assert false
   | Public _  -> Lib_name.to_string name
-  | Private scope_name ->
-    SC.Scope_key.to_string (Lib_name.to_string name) scope_name
+  | Private project -> Scope_key.to_string name project
 
 let pkg_or_lnu lib =
   match Lib.package lib with
@@ -635,8 +661,7 @@ let gen_rules sctx ~dir:_ rest =
       let mlds = Packages.mlds sctx pkg in
       setup_package_odoc_rules sctx ~pkg ~mlds)
   | "_odoc" :: "lib" :: lib :: _ ->
-    let lib, lib_db = SC.Scope_key.of_string sctx lib in
-    let lib = Lib_name.of_string_exn ~loc:None lib in
+    let lib, lib_db = Scope_key.of_string sctx lib in
     (* diml: why isn't [None] some kind of error here? *)
     Option.iter (Lib.DB.find lib_db lib) ~f:(fun lib ->
       (* TODO instead of this hack, call memoized function that
@@ -647,8 +672,7 @@ let gen_rules sctx ~dir:_ rest =
   | "_html" :: lib_unique_name_or_pkg :: _ ->
     (* TODO we can be a better with the error handling in the case where
        lib_unique_name_or_pkg is neither a valid pkg or lnu *)
-    let lib, lib_db = SC.Scope_key.of_string sctx lib_unique_name_or_pkg in
-    let lib = Lib_name.of_string_exn ~loc:None lib in
+    let lib, lib_db = Scope_key.of_string sctx lib_unique_name_or_pkg in
     let setup_pkg_html_rules pkg =
       setup_pkg_html_rules sctx ~pkg ~libs:(
         Lib.Local.Set.to_list (load_all_odoc_rules_pkg sctx ~pkg)) in