diff --git a/bin/describe/describe_external_lib_deps.ml b/bin/describe/describe_external_lib_deps.ml index 9069e3fa4ce..137e53b0ce6 100644 --- a/bin/describe/describe_external_lib_deps.ml +++ b/bin/describe/describe_external_lib_deps.ml @@ -68,13 +68,17 @@ type dep = let is_external db name = let open Memo.O in - let+ lib = Dune_rules.Lib.DB.find_even_when_hidden db name in - match lib with - | None -> true - | Some t -> - (match Dune_rules.Lib_info.status (Dune_rules.Lib.info t) with - | Installed_private | Public _ | Private _ -> false - | Installed -> true) + Dune_rules.Lib.DB.find_stanza_id db name + >>= function + | None -> Memo.return true + | Some library_id -> + let+ lib = Dune_rules.Lib.DB.find_even_when_hidden db library_id in + (match lib with + | None -> true + | Some t -> + (match Dune_rules.Lib_info.status (Dune_rules.Lib.info t) with + | Installed_private | Public _ | Private _ -> false + | Installed -> true)) ;; let resolve_lib db name kind = diff --git a/bin/describe/describe_workspace.ml b/bin/describe/describe_workspace.ml index 8f93a6ef79f..f3a90abccce 100644 --- a/bin/describe/describe_workspace.ml +++ b/bin/describe/describe_workspace.ml @@ -447,9 +447,10 @@ module Crawl = struct | true -> (* XXX why do we have a second object directory? *) let* modules_, obj_dir_ = + let library_id = Lib.library_id lib in Dir_contents.get sctx ~dir:(Path.as_in_build_dir_exn src_dir) >>= Dir_contents.ocaml - >>| Ml_sources.modules_and_obj_dir ~for_:(Library name) + >>| Ml_sources.modules_and_obj_dir ~for_:(Library library_id) in let* pp_map = let+ version = diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index f01b7ee6d23..7b3fd4d5aca 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -259,9 +259,9 @@ end = struct in let stanzas = Dune_file.stanzas d in let project = Dune_file.project d in + let src_dir = Dune_file.dir d in let+ files, rules = Rules.collect (fun () -> - let src_dir = Dune_file.dir d in stanzas >>= load_text_files sctx st_dir ~src_dir ~dir) in let dirs = [ { Source_file_dir.dir; path_to_root = []; files } ] in @@ -292,7 +292,7 @@ end = struct ; foreign_sources = Memo.lazy_ (fun () -> let dune_version = Dune_project.dune_version project in - stanzas >>| Foreign_sources.make ~dune_version ~dirs) + stanzas >>| Foreign_sources.make ~src_dir ~dune_version ~dirs) ; coq = Memo.lazy_ (fun () -> stanzas >>| Coq_sources.of_dir ~dir ~include_subdirs ~dirs) @@ -321,16 +321,11 @@ end = struct let ctx = Super_context.context sctx in let stanzas = Dune_file.stanzas dune_file in let project = Dune_file.project dune_file in + let src_dir = Dune_file.dir dune_file in let+ (files, subdirs), rules = Rules.collect (fun () -> Memo.fork_and_join - (fun () -> - stanzas - >>= load_text_files - sctx - source_dir - ~src_dir:(Dune_file.dir dune_file) - ~dir) + (fun () -> stanzas >>= load_text_files sctx source_dir ~src_dir ~dir) (fun () -> Memo.parallel_map components @@ -370,7 +365,7 @@ end = struct let foreign_sources = Memo.lazy_ (fun () -> let dune_version = Dune_project.dune_version project in - stanzas >>| Foreign_sources.make ~dune_version ~dirs) + stanzas >>| Foreign_sources.make ~src_dir ~dune_version ~dirs) in let coq = Memo.lazy_ (fun () -> @@ -456,8 +451,11 @@ let modules_of_local_lib sctx lib = let dir = Lib_info.src_dir info in get sctx ~dir in - let name = Lib_info.name info in - ocaml t >>| Ml_sources.modules ~for_:(Library name) + let library_id = + let lib = Lib.Local.to_lib lib in + Lib.library_id lib + in + ocaml t >>| Ml_sources.modules ~for_:(Library library_id) ;; let modules_of_lib sctx lib = diff --git a/src/dune_rules/dune_package.ml b/src/dune_rules/dune_package.ml index 813907005a7..0b5b7e966f3 100644 --- a/src/dune_rules/dune_package.ml +++ b/src/dune_rules/dune_package.ml @@ -311,6 +311,14 @@ module Lib = struct let info dp = dp.info let external_location dp = dp.external_location + let library_id dp = + let info = info dp in + let loc = Lib_info.loc info + and name = Lib_info.name info + and src_dir = Lib_info.src_dir info in + Library.Id.external_ ~loc ~src_dir ~enabled_if:Blang.true_ name + ;; + let to_dyn { info; main_module_name; external_location } = let open Dyn in record @@ -358,12 +366,12 @@ end module Entry = struct type t = | Library of Lib.t - | Deprecated_library_name of Deprecated_library_name.t + | Deprecated_library_name of Path.t * Deprecated_library_name.t | Hidden_library of Lib.t let name = function | Library lib | Hidden_library lib -> Lib_info.name (Lib.info lib) - | Deprecated_library_name d -> d.old_public_name + | Deprecated_library_name (_, d) -> d.old_public_name ;; let version = function @@ -373,7 +381,17 @@ module Entry = struct let loc = function | Library lib | Hidden_library lib -> Lib_info.loc (Lib.info lib) - | Deprecated_library_name d -> d.loc + | Deprecated_library_name (_, d) -> d.loc + ;; + + let library_id = function + | Library lib | Hidden_library lib -> + let info = Lib.info lib in + let loc = Lib_info.loc info + and name = Lib_info.name info + and src_dir = Lib_info.src_dir info in + Library.Id.external_ ~loc ~src_dir ~enabled_if:Blang.true_ name + | Deprecated_library_name _ -> assert false ;; let cstrs ~lang ~dir = @@ -383,7 +401,7 @@ module Entry = struct Library lib ) ; ( "deprecated_library_name" , let+ x = Deprecated_library_name.decode in - Deprecated_library_name x ) + Deprecated_library_name (dir, x) ) ] ;; @@ -391,7 +409,7 @@ module Entry = struct let open Dyn in match x with | Library lib -> variant "Library" [ Lib.to_dyn lib ] - | Deprecated_library_name lib -> + | Deprecated_library_name (_, lib) -> variant "Deprecated_library_name" [ Deprecated_library_name.to_dyn lib ] | Hidden_library lib -> variant "Hidden_library" [ Lib.to_dyn lib ] ;; @@ -516,7 +534,7 @@ let encode ~dune_version { entries; name; version; dir; sections; sites; files } match e with | Entry.Library lib -> list (Dune_lang.atom "library" :: Lib.encode lib ~package_root:dir ~stublibs) - | Deprecated_library_name d -> + | Deprecated_library_name (_, d) -> list (Dune_lang.atom "deprecated_library_name" :: Deprecated_library_name.encode d) | Hidden_library lib -> Code_error.raise diff --git a/src/dune_rules/dune_package.mli b/src/dune_rules/dune_package.mli index 79d01f90bea..b7d799a08f7 100644 --- a/src/dune_rules/dune_package.mli +++ b/src/dune_rules/dune_package.mli @@ -23,6 +23,7 @@ module Lib : sig 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 library_id : t -> Library.Id.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 @@ -42,7 +43,7 @@ end module Entry : sig type t = | Library of Lib.t - | Deprecated_library_name of Deprecated_library_name.t + | Deprecated_library_name of Path.t * Deprecated_library_name.t | Hidden_library of Lib.t (** Only for external libraries that: @@ -55,6 +56,7 @@ module Entry : sig val name : t -> Lib_name.t val version : t -> Package_version.t option val loc : t -> Loc.t + val library_id : t -> Library.Id.t val to_dyn : t Dyn.builder end diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index ce37d2cd3ef..f186909f696 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -157,16 +157,29 @@ let expand_version { scope; _ } ~(source : Dune_lang.Template.Pform.t) s = allowed" ]; let open Memo.O in - Lib.DB.find (Scope.libs scope) libname - >>| (function - | Some lib -> value_from_version (Lib_info.version (Lib.info lib)) + (* TODO(anmonteiro): check *) + let db = Scope.libs scope in + Lib.DB.find_stanza_id db libname + >>= (function | None -> User_error.raise ~loc:source.loc [ Pp.textf "Package %S doesn't exist in the current project and isn't installed either." s - ]) + ] + | Some library_id -> + Lib.DB.find db library_id + >>| (function + | Some lib -> value_from_version (Lib_info.version (Lib.info lib)) + | None -> + User_error.raise + ~loc:source.loc + [ Pp.textf + "Package %S doesn't exist in the current project and isn't installed \ + either." + s + ])) ;; let expand_artifact ~source t artifact arg = @@ -402,7 +415,9 @@ let expand_lib_variable t source ~lib ~file ~lib_exec ~lib_private = then Resolve.Memo.map p ~f:(fun _ -> assert false) else let open Resolve.Memo.O in - Lib.DB.available (Scope.libs scope) lib + let db = Scope.libs scope in + let* library_id = Resolve.Memo.lift_memo (Lib.DB.find_stanza_id db lib) in + Lib.DB.available db (Option.value_exn library_id) |> Resolve.Memo.lift_memo >>= function | false -> @@ -653,7 +668,11 @@ let expand_pform_macro (let lib = Lib_name.parse_string_exn (Dune_lang.Template.Pform.loc source, s) in let open Memo.O in let* scope = t.scope in - let+ available = Lib.DB.available (Scope.libs scope) lib in + let db = Scope.libs scope in + let+ available = + let* library_id = Lib.DB.find_stanza_id db lib in + Lib.DB.available db (Option.value_exn library_id) + in available |> string_of_bool |> string)) | Bin_available -> Need_full_expander diff --git a/src/dune_rules/findlib.ml b/src/dune_rules/findlib.ml index 88450ed7e9c..03f277381cf 100644 --- a/src/dune_rules/findlib.ml +++ b/src/dune_rules/findlib.ml @@ -23,10 +23,11 @@ end let builtin_for_dune : Dune_package.t = let entry = Dune_package.Entry.Deprecated_library_name - { loc = Loc.of_pos __POS__ - ; old_public_name = Lib_name.of_string "dune.configurator" - ; new_public_name = Lib_name.of_string "dune-configurator" - } + ( Path.external_ Path.External.initial_cwd + , { loc = Loc.of_pos __POS__ + ; old_public_name = Lib_name.of_string "dune.configurator" + ; new_public_name = Lib_name.of_string "dune-configurator" + } ) in { name = Opam_package.Name.of_string "dune" ; entries = Lib_name.Map.singleton (Dune_package.Entry.name entry) entry diff --git a/src/dune_rules/foreign_sources.ml b/src/dune_rules/foreign_sources.ml index 0bc3b419ac6..d0d6e9998de 100644 --- a/src/dune_rules/foreign_sources.ml +++ b/src/dune_rules/foreign_sources.ml @@ -9,12 +9,12 @@ open Import Furthermore, this module is also responsible for details such as handling file extensions and validating filenames. *) type t = - { libraries : Foreign.Sources.t Lib_name.Map.t + { libraries : Foreign.Sources.t Library.Id.Map.t ; archives : Foreign.Sources.t Foreign.Archive.Name.Map.t ; executables : Foreign.Sources.t String.Map.t } -let for_lib t ~name = Lib_name.Map.find_exn t.libraries name +let for_lib t ~library_id = Library.Id.Map.find_exn t.libraries library_id let for_archive t ~archive_name = Foreign.Archive.Name.Map.find_exn t.archives archive_name @@ -23,7 +23,7 @@ let for_archive t ~archive_name = let for_exes t ~first_exe = String.Map.find_exn t.executables first_exe let empty = - { libraries = Lib_name.Map.empty + { libraries = Library.Id.Map.empty ; archives = Foreign.Archive.Name.Map.empty ; executables = String.Map.empty } @@ -165,7 +165,7 @@ let eval_foreign_stubs ~paths:Foreign.Source.[ path src1; path src2 ])) ;; -let make stanzas ~(sources : Foreign.Sources.Unresolved.t) ~dune_version = +let make stanzas ~src_dir ~(sources : Foreign.Sources.Unresolved.t) ~dune_version = let libs, foreign_libs, exes = let libs, foreign_libs, exes = List.fold_left @@ -245,14 +245,17 @@ let make stanzas ~(sources : Foreign.Sources.Unresolved.t) ~dune_version = String.Map.of_list_map_exn exes ~f:(fun (exes, m) -> snd (List.hd exes.names), m) in let libraries = - match Lib_name.Map.of_list_map libs ~f:(fun (lib, m) -> Library.best_name lib, m) with + match + Library.Id.Map.of_list_map libs ~f:(fun (lib, m) -> + Library.Id.of_stanza ~src_dir lib, m) + with | Ok x -> x - | Error (name, _, (lib2, _)) -> + | Error (library_id, _, (lib2, _)) -> User_error.raise ~loc:lib2.buildable.loc [ Pp.textf "Library %S appears for the second time in this directory" - (Lib_name.to_string name) + (Lib_name.to_string (Library.Id.name library_id)) ] in let archives = @@ -286,7 +289,7 @@ let make stanzas ~(sources : Foreign.Sources.Unresolved.t) ~dune_version = { libraries; archives; executables } ;; -let make stanzas ~dune_version ~dirs = +let make stanzas ~src_dir ~dune_version ~dirs = let init = String.Map.empty in let sources = List.fold_left @@ -296,5 +299,5 @@ let make stanzas ~dune_version ~dirs = let sources = Foreign.Sources.Unresolved.load ~dir ~dune_version ~files in String.Map.Multi.rev_union sources acc) in - make stanzas ~dune_version ~sources + make ~src_dir stanzas ~dune_version ~sources ;; diff --git a/src/dune_rules/foreign_sources.mli b/src/dune_rules/foreign_sources.mli index 86e6f72d996..ad73464ae23 100644 --- a/src/dune_rules/foreign_sources.mli +++ b/src/dune_rules/foreign_sources.mli @@ -5,12 +5,13 @@ open Import type t val empty : t -val for_lib : t -> name:Lib_name.t -> Foreign.Sources.t +val for_lib : t -> library_id:Library.Id.t -> Foreign.Sources.t val for_archive : t -> archive_name:Foreign.Archive.Name.t -> Foreign.Sources.t val for_exes : t -> first_exe:string -> Foreign.Sources.t val make : Stanza.t list + -> src_dir:Path.Source.t -> dune_version:Syntax.Version.t -> dirs:Source_file_dir.t list -> t diff --git a/src/dune_rules/gen_meta.ml b/src/dune_rules/gen_meta.ml index ad6bf39056c..764604905a5 100644 --- a/src/dune_rules/gen_meta.ml +++ b/src/dune_rules/gen_meta.ml @@ -163,7 +163,7 @@ let gen ~(package : Package.t) ~add_directory_entry entries = let+ pkgs = Memo.parallel_map entries ~f:(fun (e : Scope.DB.Lib_entry.t) -> match e with - | Library lib -> + | Library (_, lib) -> let info = Lib.Local.info lib in let pub_name = let name = Lib_info.name info in diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index bc02fd88563..6a1ac27e479 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -111,42 +111,14 @@ end = struct let+ () = Toplevel.Stanza.setup ~sctx ~dir ~toplevel in empty_none | Library.T lib -> - (* This check surfaces conflicts between private names of public libraries, - without it the user might get duplicated rules errors for cmxs - when the libraries are defined in the same folder and have the same private name *) - let* resolve_result = - let db = Scope.libs scope in - let loc, name = - let ((loc, _) as name) = lib.name in - loc, Lib_name.of_local name - in - Lib.DB.resolve db (loc, name) + let* enabled_if = + let stanza_id = Library.Id.of_stanza ~src_dir lib in + Lib.DB.available (Scope.libs scope) stanza_id in - (match Resolve.to_result resolve_result with - | Error err -> Resolve.raise_error_with_stack_trace err - | Ok _ -> - let* lib_info = - let* ocaml = - let ctx = Super_context.context sctx in - Context.ocaml ctx - in - let lib_config = ocaml.lib_config in - Memo.return (Library.to_lib_info lib ~dir ~lib_config) - in - let* enabled_in_context = - let* enabled = - Lib_info.enabled - (lib_info ~expander:(Memo.return (Expander.to_expander0 expander))) - in - match enabled with - | Disabled_because_of_enabled_if -> Memo.return false - | Normal | Optional -> Memo.return true - in - let* available = Lib.DB.available (Scope.libs scope) (Library.best_name lib) in - if_available_buildable - ~loc:lib.buildable.loc - (fun () -> Lib_rules.rules lib ~sctx ~dir ~scope ~dir_contents ~expander) - (enabled_in_context && available)) + if_available_buildable + ~loc:lib.buildable.loc + (fun () -> Lib_rules.rules lib ~sctx ~dir ~scope ~dir_contents ~expander) + enabled_if | Foreign.Library.T lib -> Expander.eval_blang expander lib.enabled_if >>= if_available (fun () -> diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 65ef2c87374..24ef981c016 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -85,17 +85,16 @@ end = struct >>| List.singleton ;; - let lib_files ~dir_contents ~dir ~lib_config lib = + let lib_files ~dir_contents ~dir ~lib_config ~library_id lib = let+ modules = let+ ml_sources = Dir_contents.ocaml dir_contents in - Some (Ml_sources.modules ml_sources ~for_:(Library (Lib_info.name lib))) + Some (Ml_sources.modules ml_sources ~for_:(Library library_id)) and+ foreign_archives = match Lib_info.virtual_ lib with | None -> Memo.return (Mode.Map.Multi.to_flat_list @@ Lib_info.foreign_archives lib) | Some _ -> let+ foreign_sources = Dir_contents.foreign_sources dir_contents in - let name = Lib_info.name lib in - let files = Foreign_sources.for_lib foreign_sources ~name in + let files = Foreign_sources.for_lib foreign_sources ~library_id in let { Lib_config.ext_obj; _ } = lib_config in Foreign.Sources.object_files files ~dir ~ext_obj in @@ -179,9 +178,13 @@ end = struct ~lib_config in let lib_name = Library.best_name lib in + let library_id = + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + Library.Id.of_stanza ~src_dir lib + in let* installable_modules = let+ modules = - Dir_contents.ocaml dir_contents >>| Ml_sources.modules ~for_:(Library lib_name) + Dir_contents.ocaml dir_contents >>| Ml_sources.modules ~for_:(Library library_id) and+ impl = Virtual_rules.impl sctx ~lib ~scope in Vimpl.impl_modules impl modules |> Modules.split_by_lib in @@ -305,7 +308,7 @@ end = struct if Module.kind m = Virtual then [] else common m |> set_dir m) in modules_vlib @ modules_impl - and+ lib_files = lib_files ~dir ~dir_contents ~lib_config info + and+ lib_files = lib_files ~dir ~dir_contents ~lib_config ~library_id info and+ execs = lib_ppxs ctx ~scope ~lib and+ dll_files = dll_files ~modes:ocaml ~dynlink:lib.dynlink ~ctx info @@ -338,7 +341,10 @@ end = struct if enabled_if then if lib.optional - then Lib.DB.available (Scope.libs scope) (Library.best_name lib) + then ( + let db = Scope.libs scope in + let* library_id = Lib.DB.find_stanza_id db (Library.best_name lib) in + Lib.DB.available db (Option.value_exn library_id)) else Memo.return true else Memo.return false | Documentation.T _ -> Memo.return true @@ -620,8 +626,8 @@ end = struct (Some ( old_public_name , Dune_package.Entry.Deprecated_library_name - { loc; old_public_name; new_public_name } )) - | Library lib -> + (Path.build pkg_root, { loc; old_public_name; new_public_name }) )) + | Library (library_id, lib) -> let info = Lib.Local.info lib in let dir = Lib_info.src_dir info in let* dir_contents = Dir_contents.get sctx ~dir in @@ -649,11 +655,12 @@ end = struct ocaml.lib_config.ext_obj in let+ foreign_sources = Dir_contents.foreign_sources dir_contents in - Foreign_sources.for_lib ~name foreign_sources + Foreign_sources.for_lib ~library_id foreign_sources |> Foreign.Sources.object_files ~dir ~ext_obj |> List.map ~f:Path.build and* modules = - Dir_contents.ocaml dir_contents >>| Ml_sources.modules ~for_:(Library name) + Dir_contents.ocaml dir_contents + >>| Ml_sources.modules ~for_:(Library library_id) and* melange_runtime_deps = file_deps (Lib_info.melange_runtime_deps info) and* public_headers = file_deps (Lib_info.public_headers info) in let+ dune_lib = @@ -730,6 +737,9 @@ end = struct acc >>> let dune_pkg = + let dir = + Path.build (Install.Context.lib_dir ~context:ctx.name ~package:name) + in let entries = match Package.Name.Map.find deprecated_dune_packages name with | None -> Lib_name.Map.empty @@ -751,13 +761,13 @@ end = struct acc old_public_name (Dune_package.Entry.Deprecated_library_name - { loc; old_public_name; new_public_name })) + (dir, { loc; old_public_name; new_public_name }))) in let sections = sections ctx.name [] pkg in { Dune_package.version = Package.version pkg ; name ; entries - ; dir = Path.build (Install.Context.lib_dir ~context:ctx.name ~package:name) + ; dir ; sections ; sites = Package.sites pkg ; files = [] @@ -798,7 +808,7 @@ end = struct let* () = Action_builder.return () in match List.find_map entries ~f:(function - | Library lib -> + | Library (_, lib) -> let info = Lib.Local.info lib in Option.some_if (Option.is_some (Lib_info.virtual_ info)) lib | Deprecated_library_name _ -> None) diff --git a/src/dune_rules/jsoo/jsoo_rules.ml b/src/dune_rules/jsoo/jsoo_rules.ml index 90c97dbb47b..5c68ba3fadd 100644 --- a/src/dune_rules/jsoo/jsoo_rules.ml +++ b/src/dune_rules/jsoo/jsoo_rules.ml @@ -407,47 +407,53 @@ let setup_separate_compilation_rules sctx components = let ctx = Super_context.context sctx in let open Memo.O in let* installed_libs = Lib.DB.installed ctx in - Lib.DB.find installed_libs pkg + Lib.DB.find_stanza_id installed_libs pkg >>= (function | None -> Memo.return () - | Some pkg -> - let info = Lib.info pkg in - let lib_name = Lib_name.to_string (Lib.name pkg) in - let archives = - let archives = (Lib_info.archives info).byte in - (* Special case for the stdlib because it is not referenced in the - META *) - match lib_name with - | "stdlib" -> - let archive = - let stdlib_dir = (Lib.lib_config pkg).stdlib_dir in - Path.relative stdlib_dir - in - archive "stdlib.cma" :: archive "std_exit.cmo" :: archives - | _ -> archives - in - Memo.parallel_iter archives ~f:(fun fn -> - let build_context = Context.build_context ctx in - let name = Path.basename fn in - let dir = in_build_dir build_context ~config [ lib_name ] in - let in_context = - { Js_of_ocaml.In_context.flags = Js_of_ocaml.Flags.standard - ; javascript_files = [] - } - in - let src = - let src_dir = Lib_info.src_dir info in - Path.relative src_dir name - in - let target = in_build_dir build_context ~config [ lib_name; with_js_ext name ] in - build_cm' - sctx - ~dir - ~in_context - ~src - ~target - ~config:(Some (Action_builder.return config)) - |> Super_context.add_rule sctx ~dir)) + | Some library_id -> + Lib.DB.find installed_libs library_id + >>= (function + | None -> Memo.return () + | Some pkg -> + let info = Lib.info pkg in + let lib_name = Lib_name.to_string (Lib.name pkg) in + let archives = + let archives = (Lib_info.archives info).byte in + (* Special case for the stdlib because it is not referenced in the + META *) + match lib_name with + | "stdlib" -> + let archive = + let stdlib_dir = (Lib.lib_config pkg).stdlib_dir in + Path.relative stdlib_dir + in + archive "stdlib.cma" :: archive "std_exit.cmo" :: archives + | _ -> archives + in + Memo.parallel_iter archives ~f:(fun fn -> + let build_context = Context.build_context ctx in + let name = Path.basename fn in + let dir = in_build_dir build_context ~config [ lib_name ] in + let in_context = + { Js_of_ocaml.In_context.flags = Js_of_ocaml.Flags.standard + ; javascript_files = [] + } + in + let src = + let src_dir = Lib_info.src_dir info in + Path.relative src_dir name + in + let target = + in_build_dir build_context ~config [ lib_name; with_js_ext name ] + in + build_cm' + sctx + ~dir + ~in_context + ~src + ~target + ~config:(Some (Action_builder.return config)) + |> Super_context.add_rule sctx ~dir))) ;; let js_of_ocaml_compilation_mode t ~dir = diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index c4059e9b2c7..2fd0065d0d5 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -329,6 +329,7 @@ module T = struct { info : Lib_info.external_ ; name : Lib_name.t ; unique_id : Id.t + ; library_id : Library.Id.t ; re_exports : t list Resolve.t ; (* [requires] is contains all required libraries, including the ones mentioned in [re_exports]. *) @@ -394,24 +395,34 @@ module Status = struct | Invalid of User_message.t | Ignore - let to_dyn t = - let open Dyn in - match t with - | Invalid e -> variant "Invalid" [ Dyn.string (User_message.to_string e) ] - | Not_found -> variant "Not_found" [] - | Hidden { lib = _; path; reason } -> - variant "Hidden" [ Path.to_dyn path; string reason ] - | Found t -> variant "Found" [ to_dyn t ] - | Ignore -> variant "Ignore" [] + let to_dyn = + let lib_to_dyn = to_dyn in + let (* rec *) to_dyn t = + let open Dyn in + match t with + | Invalid e -> variant "Invalid" [ Dyn.string (User_message.to_string e) ] + | Not_found -> variant "Not_found" [] + | Hidden { lib = _; path; reason } -> + variant "Hidden" [ Path.to_dyn path; string reason ] + | Found t -> variant "Found" [ lib_to_dyn t ] + | Ignore -> variant "Ignore" [] + in + to_dyn ;; end type db = { parent : db option - ; resolve : Lib_name.t -> resolve_result Memo.t + ; find_stanza_id : Lib_name.t -> Library.Id.t list Memo.t + ; resolve : Library.Id.t -> resolve_result Memo.t ; instantiate : - (Lib_name.t -> Path.t Lib_info.t -> hidden:string option -> Status.t Memo.t) Lazy.t - ; all : Lib_name.t list Memo.Lazy.t + (Lib_name.t + -> Library.Id.t + -> Path.t Lib_info.t + -> hidden:string option + -> Status.t Memo.t) + Lazy.t + ; all : Library.Id.t list Memo.Lazy.t ; lib_config : Lib_config.t ; instrument_with : Lib_name.t list } @@ -423,12 +434,12 @@ and resolve_result = | Invalid of User_message.t | Ignore | Redirect_in_the_same_db of (Loc.t * Lib_name.t) - | Multiple_results of resolve_result list - | Redirect of db * (Loc.t * Lib_name.t) + | Redirect of db * Library.Id.t | Deprecated_library_name of (Loc.t * Lib_name.t) let lib_config (t : lib) = t.lib_config let name t = t.name +let library_id t = t.library_id let info t = t.info let project t = t.project let implements t = Option.map ~f:Memo.return t.implements @@ -823,6 +834,7 @@ let instrumentation_backend instrument_with resolve libname = module rec Resolve_names : sig val find_internal : db -> Lib_name.t -> Status.t Memo.t + val find_stanza_id_internal : db -> Lib_name.t -> Library.Id.t list Memo.t val resolve_dep : db @@ -830,8 +842,8 @@ module rec Resolve_names : sig -> private_deps:private_deps -> lib Resolve.t option Memo.t - val resolve_name : db -> Lib_name.t -> Status.t Memo.t - val available_internal : db -> Lib_name.t -> bool Memo.t + val resolve_library_id : db -> Library.Id.t -> Status.t Memo.t + val available_internal : db -> Library.Id.t -> bool Memo.t val resolve_simple_deps : db @@ -870,7 +882,11 @@ module rec Resolve_names : sig val make_instantiate : db Lazy.t - -> (Lib_name.t -> Path.t Lib_info.t -> hidden:string option -> Status.t Memo.t) + -> (Lib_name.t + -> Library.Id.t + -> Path.t Lib_info.t + -> hidden:string option + -> Status.t Memo.t) Staged.t end = struct open Resolve_names @@ -887,7 +903,7 @@ end = struct >>| Package.Name.Map.of_list_exn) ;; - let instantiate_impl db (name, info, hidden) = + let instantiate_impl db (name, library_id, info, hidden) = let db = Lazy.force db in let open Memo.O in let unique_id = Id.make ~name ~path:(Lib_info.src_dir info) in @@ -1051,6 +1067,7 @@ end = struct { info ; name ; unique_id + ; library_id ; requires ; ppx_runtime_deps ; pps @@ -1096,13 +1113,13 @@ end = struct ;; module Input = struct - type t = Lib_name.t * Path.t Lib_info.t * string option + type t = Lib_name.t * Library.Id.t * Path.t Lib_info.t * string option - let equal (lib_name, info, _) (lib_name', info', _) = - Lib_name.equal lib_name lib_name' && Lib_info.equal info info' + let equal (lib_name, library_id, _, _) (lib_name', library_id', _, _) = + Lib_name.equal lib_name lib_name' && Library.Id.equal library_id library_id' ;; - let hash (x, _, _) = Lib_name.hash x + let hash (x, _, _, _) = Lib_name.hash x let to_dyn = Dyn.opaque end @@ -1111,6 +1128,7 @@ end = struct module Rec : sig val memo : Lib_name.t + -> Library.Id.t -> Path.t Lib_info.t -> hidden:string option -> Status.t Memo.t @@ -1121,10 +1139,11 @@ end = struct "db-instantiate" ~input:(module Input) (instantiate_impl db) - ~human_readable_description:(fun (name, info, _hidden) -> + ~human_readable_description:(fun (name, _library_id, info, _hidden) -> Dep_path.Entry.Lib.pp { name; path = Lib_info.src_dir info }) in - fun name info ~hidden -> Memo.exec memo (name, info, hidden) + fun name library_id info ~hidden -> + Memo.exec memo (name, library_id, info, hidden) ;; end end @@ -1133,60 +1152,80 @@ end = struct ;; let instantiate db name info ~hidden = (Lazy.force db.instantiate) name info ~hidden - let find_internal db (name : Lib_name.t) = resolve_name db name - - let resolve_dep db (loc, name) ~private_deps : t Resolve.t option Memo.t = - let open Memo.O in - find_internal db name - >>= function - | Ignore -> Memo.return None - | Found lib -> - check_private_deps lib ~loc ~private_deps |> Resolve.Memo.of_result >>| Option.some - | Not_found -> Error.not_found ~loc ~name >>| Option.some - | Invalid why -> Resolve.Memo.of_result (Error why) >>| Option.some - | Hidden h -> Hidden.error h ~loc ~name >>| Option.some - ;; + let find_stanza_id_internal db (name : Lib_name.t) = db.find_stanza_id name - let resolve_name db name = + let find_internal db (name : Lib_name.t) = let open Memo.O in - db.resolve name - >>= function - | Ignore -> Memo.return Status.Ignore - | Deprecated_library_name (_, name') -> find_internal db name' - | Redirect_in_the_same_db (_, name') -> find_internal db name' - | Redirect (db', (_, name')) -> find_internal db' name' - | Found info -> instantiate db name info ~hidden:None - | Multiple_results libs -> + find_stanza_id_internal db name + >>= fun xs -> + match xs with + | [] -> + (match db.parent with + | None -> Memo.return Status.Not_found + | Some db -> find_internal db name) + | [ library_id ] -> resolve_library_id db library_id + | candidates -> + (* let+ results = + Memo.List.filter_map candidates ~f:(fun candidate -> + let+ status = resolve_library_id db candidate in + match status with + | Found _ | Hidden _ -> Some status + | Not_found | Ignore -> None + | Invalid _ -> assert false) + in + (match results with + | [] -> Status.Not_found + | [ status ] -> status + | _ :: _ -> + let main_message = + let name = Library.Id.name lib1 in + Pp.textf "Library %s is defined twice:" (Lib_name.to_string name) + in + let loc1 = Library.Id.loc lib1 + and loc2 = Library.Id.loc lib2 in + let annots = + let main = User_message.make ~loc:loc2 [ main_message ] in + let related = + [ User_message.make ~loc:loc1 [ Pp.text "Already defined here" ] ] + in + User_message.Annots.singleton + Compound_user_error.annot + [ Compound_user_error.make ~main ~related ] + in + User_error.raise + ~annots + [ main_message + ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) + ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) + ]) *) let* libs = - Memo.List.filter_map - ~f:(function - | Ignore -> Memo.return (Some Status.Ignore) - | Deprecated_library_name (_, name') -> - find_internal db name' >>| fun f -> Some f - | Redirect_in_the_same_db (_, name') -> - find_internal db name' >>| fun f -> Some f - | Redirect (db', (_, name')) -> find_internal db' name' >>| fun f -> Some f - | Found info -> - let* enabled = Lib_info.enabled info in - (match enabled with - | Disabled_because_of_enabled_if -> Memo.return None - | Normal | Optional -> - instantiate db name info ~hidden:None >>| fun f -> Some f) - | Multiple_results _libs -> - (* There can't be nested Multiple_results *) assert false - | Invalid e -> Memo.return (Some (Status.Invalid e)) - | Not_found -> - (match db.parent with - | None -> Memo.return (Some Status.Not_found) - | Some db -> find_internal db name >>| fun f -> Some f) - | Hidden { lib = info; reason = hidden; path = _ } -> - (match db.parent with - | None -> Memo.return Status.Not_found - | Some db -> find_internal db name) - >>= (function - | Status.Found _ as x -> Memo.return (Some x) - | _ -> instantiate db name info ~hidden:(Some hidden) >>| fun f -> Some f)) - libs + let libs = candidates in + Memo.List.filter_map libs ~f:(fun candidate -> + let* status = resolve_library_id db candidate in + match status with + | Ignore -> Memo.return (Some Status.Ignore) + | Found lib -> + let info = lib.info in + let* enabled = Lib_info.enabled info in + (match enabled with + | Disabled_because_of_enabled_if -> Memo.return None + | Normal | Optional -> + instantiate db name lib.library_id info ~hidden:None >>| fun f -> Some f) + | Invalid e -> Memo.return (Some (Status.Invalid e)) + | Not_found -> + (match db.parent with + | None -> Memo.return (Some Status.Not_found) + | Some db -> resolve_library_id db candidate >>| fun f -> Some f) + | Hidden { lib; reason = hidden; path = _ } -> + (match db.parent with + | None -> Memo.return Status.Not_found + | Some db -> resolve_library_id db candidate) + >>= (function + | Status.Found _ as x -> Memo.return (Some x) + | _ -> + let info = lib.info in + instantiate db name lib.library_id info ~hidden:(Some hidden) + >>| fun f -> Some f)) in (match libs with | [] -> assert false @@ -1207,23 +1246,50 @@ end = struct | (Hidden _ | Ignore | Not_found), (Found _ as lib) -> lib | ( (Hidden _ | Ignore | Not_found) , (Hidden _ | Ignore | Not_found | Invalid _) ) -> acc))) + ;; + + let resolve_dep db (loc, name) ~private_deps : t Resolve.t option Memo.t = + let open Memo.O in + find_internal db name + >>= function + | Ignore -> Memo.return None + | Found lib -> + check_private_deps lib ~loc ~private_deps |> Resolve.Memo.of_result >>| Option.some + | Not_found -> Error.not_found ~loc ~name >>| Option.some + | Invalid why -> Resolve.Memo.of_result (Error why) >>| Option.some + | Hidden h -> Hidden.error h ~loc ~name >>| Option.some + ;; + + let resolve_library_id db library_id = + let open Memo.O in + db.resolve library_id + >>= function + | Ignore -> Memo.return Status.Ignore + | Deprecated_library_name (_, name') -> find_internal db name' + | Redirect_in_the_same_db (_, name') -> find_internal db name' + | Redirect (db', library_id') -> resolve_library_id db' library_id' + | Found info -> + let name = Lib_info.name info in + instantiate db name library_id info ~hidden:None | Invalid e -> Memo.return (Status.Invalid e) | Not_found -> (match db.parent with | None -> Memo.return Status.Not_found - | Some db -> find_internal db name) + | Some db -> resolve_library_id db library_id) | Hidden { lib = info; reason = hidden; path = _ } -> (match db.parent with | None -> Memo.return Status.Not_found - | Some db -> find_internal db name) + | Some db -> resolve_library_id db library_id) >>= (function | Status.Found _ as x -> Memo.return x - | _ -> instantiate db name info ~hidden:(Some hidden)) + | _ -> + let name = Lib_info.name info in + instantiate db name library_id info ~hidden:(Some hidden)) ;; - let available_internal db (name : Lib_name.t) = + let available_internal db (library_id : Library.Id.t) = let open Memo.O in - find_internal db name + resolve_library_id db library_id >>| function | Ignore | Found _ -> true | Not_found | Invalid _ | Hidden _ -> false @@ -1348,7 +1414,12 @@ end = struct let+ select = Memo.List.find_map choices ~f:(fun { required; forbidden; file } -> Lib_name.Set.to_list forbidden - |> Memo.List.exists ~f:(available_internal db) + |> Memo.List.exists ~f:(fun name -> + let* library_id = find_stanza_id_internal db name in + match library_id with + | [] -> Memo.return false + | [ library_id ] -> available_internal db library_id + | _libs -> assert false) >>= function | true -> Memo.return None | false -> @@ -1671,7 +1742,7 @@ end = struct | _ -> R.lift (let open Memo.O in - find_internal db lib.name + resolve_library_id db lib.library_id >>= function | Status.Found lib' -> if lib = lib' @@ -1684,6 +1755,7 @@ end = struct "Unexpected find result" [ "found", Status.to_dyn found ; "lib.name", Lib_name.to_dyn lib.name + ; "lib.library_id", Library.Id.to_dyn lib.library_id ])) in let* new_stack = R.lift (Dep_stack.push stack ~implements_via lib.unique_id) in @@ -1847,10 +1919,11 @@ module DB = struct let not_found = Not_found let redirect db lib = Redirect (db, lib) let redirect_in_the_same_db lib = Redirect_in_the_same_db lib - let multiple_results libs = Multiple_results libs + + (* let multiple_results libs = Multiple_results libs *) let deprecated_library_name lib = Deprecated_library_name lib - let rec to_dyn x = + let (* rec *) to_dyn x = let open Dyn in match x with | Not_found -> variant "Not_found" [] @@ -1858,11 +1931,11 @@ module DB = struct | Found lib -> variant "Found" [ Lib_info.to_dyn Path.to_dyn lib ] | Hidden h -> variant "Hidden" [ Hidden.to_dyn (Lib_info.to_dyn Path.to_dyn) h ] | Ignore -> variant "Ignore" [] - | Redirect (_, (_, name)) -> variant "Redirect" [ Lib_name.to_dyn name ] + | Redirect (_, library_id) -> variant "Redirect" [ Library.Id.to_dyn library_id ] | Redirect_in_the_same_db (_, name) -> variant "Redirect_in_the_same_db" [ Lib_name.to_dyn name ] - | Multiple_results redirects -> - variant "Multiple_results" [ (Dyn.list to_dyn) redirects ] + (* | Multiple_results redirects -> *) + (* variant "Multiple_results" [ (Dyn.list to_dyn) redirects ] *) | Deprecated_library_name (_, name) -> variant "Deprecated_library_name" [ Lib_name.to_dyn name ] ;; @@ -1870,10 +1943,11 @@ module DB = struct type t = db - let create ~parent ~resolve ~all ~lib_config ~instrument_with () = + let create ~parent ~find_stanza_id ~resolve ~all ~lib_config ~instrument_with () = let rec t = lazy { parent + ; find_stanza_id ; resolve ; all = Memo.lazy_ all ; lib_config @@ -1884,6 +1958,12 @@ module DB = struct Lazy.force t ;; + let to_external_id ~src_dir (t : Dune_package.Deprecated_library_name.t) = + let loc, name = t.loc, t.old_public_name + and enabled_if = Blang.true_ in + Library.Id.external_ ~loc ~src_dir ~enabled_if name + ;; + let create_from_findlib = let bigarray = Lib_name.of_string "bigarray" in fun findlib ~has_bigarray_library ~lib_config -> @@ -1891,12 +1971,30 @@ module DB = struct () ~parent:None ~lib_config - ~resolve:(fun name -> + ~find_stanza_id:(fun name -> let open Memo.O in Findlib.find findlib name >>| function + | Ok (Hidden_library pkg | Library pkg) -> [ Dune_package.Lib.library_id pkg ] + | Ok (Deprecated_library_name (src_dir, d)) -> [ to_external_id ~src_dir d ] + | Error e -> + (match e with + | Invalid_dune_package _ -> [] + | Not_found when (not has_bigarray_library) && Lib_name.equal name bigarray + -> + (* Recent versions of OCaml already include a [bigrray] library, + so we just silently ignore dependencies on it. The more + correct thing to do would be to redirect it to the stdlib, + but the stdlib isn't first class. *) + [] + | Not_found -> [])) + ~resolve:(fun library_id -> + let open Memo.O in + let name = Library.Id.name library_id in + Findlib.find findlib name + >>| function | Ok (Library pkg) -> Found (Dune_package.Lib.info pkg) - | Ok (Deprecated_library_name d) -> + | Ok (Deprecated_library_name (_, d)) -> Deprecated_library_name (d.loc, d.new_public_name) | Ok (Hidden_library pkg) -> Hidden (Hidden.unsatisfied_exist_if pkg) | Error e -> @@ -1912,7 +2010,7 @@ module DB = struct | Not_found -> Not_found)) ~all:(fun () -> let open Memo.O in - Findlib.all_packages findlib >>| List.map ~f:Dune_package.Entry.name) + Findlib.all_packages findlib >>| List.map ~f:Dune_package.Entry.library_id) ;; let installed (context : Context.t) = @@ -1926,22 +2024,31 @@ module DB = struct ~lib_config:ocaml.lib_config ;; - let find t name = + let find t library_id = let open Memo.O in - Resolve_names.find_internal t name + Resolve_names.resolve_library_id t library_id >>| function | Found t -> Some t | Ignore | Not_found | Invalid _ | Hidden _ -> None ;; - let find_even_when_hidden t name = + let find_even_when_hidden t library_id = let open Memo.O in - Resolve_names.find_internal t name + Resolve_names.resolve_library_id t library_id >>| function | Found t | Hidden { lib = t; reason = _; path = _ } -> Some t | Ignore | Invalid _ | Not_found -> None ;; + let find_stanza_id t name = + let open Memo.O in + Resolve_names.find_stanza_id_internal t name + >>| function + | [] -> None + | [ library_id ] -> Some library_id + | _libs -> assert false + ;; + let resolve_when_exists t (loc, name) = let open Memo.O in Resolve_names.find_internal t name @@ -1962,17 +2069,17 @@ module DB = struct | Some k -> Memo.return k ;; - let available t name = Resolve_names.available_internal t name + let available t library_id = Resolve_names.available_internal t library_id - let get_compile_info t ~allow_overlaps name = + let get_compile_info t ~allow_overlaps library_id = let open Memo.O in - find_even_when_hidden t name + find_even_when_hidden t library_id >>| function | Some lib -> lib, Compile.for_lib ~allow_overlaps t lib | None -> Code_error.raise "Lib.DB.get_compile_info got library that doesn't exist" - [ "name", Lib_name.to_dyn name ] + [ "library_id", Library.Id.to_dyn library_id ] ;; let resolve_user_written_deps diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index 2010742605c..dbc04d817dc 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -11,6 +11,7 @@ val to_dyn : t -> Dyn.t or the [name] if not. *) val name : t -> Lib_name.t +val library_id : t -> Library.Id.t val lib_config : t -> Lib_config.t val implements : t -> t Resolve.Memo.t option @@ -100,9 +101,10 @@ module DB : sig val not_found : t val found : Lib_info.external_ -> t val to_dyn : t Dyn.builder - val redirect : db -> Loc.t * Lib_name.t -> t + val redirect : db -> Library.Id.t -> t val redirect_in_the_same_db : Loc.t * Lib_name.t -> t - val multiple_results : t list -> t + + (* val multiple_results : t list -> t *) val deprecated_library_name : Loc.t * Lib_name.t -> t end @@ -115,23 +117,25 @@ module DB : sig [all] returns the list of names of libraries available in this database. *) val create : parent:t option - -> resolve:(Lib_name.t -> Resolve_result.t Memo.t) - -> all:(unit -> Lib_name.t list Memo.t) + -> find_stanza_id:(Lib_name.t -> Library.Id.t list Memo.t) + -> resolve:(Library.Id.t -> Resolve_result.t Memo.t) + -> all:(unit -> Library.Id.t list Memo.t) -> lib_config:Lib_config.t -> instrument_with:Lib_name.t list -> unit -> t - val find : t -> Lib_name.t -> lib option Memo.t - val find_even_when_hidden : t -> Lib_name.t -> lib option Memo.t - val available : t -> Lib_name.t -> bool Memo.t + val find : t -> Library.Id.t -> lib option Memo.t + val find_stanza_id : t -> Lib_name.t -> Library.Id.t option Memo.t + val find_even_when_hidden : t -> Library.Id.t -> lib option Memo.t + val available : t -> Library.Id.t -> bool Memo.t (** Retrieve the compile information for the given library. Works for libraries that are optional and not available as well. *) val get_compile_info : t -> allow_overlaps:bool - -> Lib_name.t + -> Library.Id.t -> (lib * Compile.t) Memo.t val resolve : t -> Loc.t * Lib_name.t -> lib Resolve.Memo.t diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index adf93213539..3578bff2ff2 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -285,8 +285,11 @@ let build_stubs lib ~cctx ~dir ~expander ~requires ~dir_contents ~vlib_stubs_o_f let sctx = Compilation_context.super_context cctx in let* foreign_sources = let+ foreign_sources = Dir_contents.foreign_sources dir_contents in - let name = Library.best_name lib in - Foreign_sources.for_lib foreign_sources ~name + let library_id = + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + Library.Id.of_stanza ~src_dir lib + in + Foreign_sources.for_lib foreign_sources ~library_id in let* o_files = let lib_foreign_o_files = @@ -644,17 +647,20 @@ let library_rules let rules (lib : Library.t) ~sctx ~dir_contents ~dir ~expander ~scope = let buildable = lib.buildable in + let library_id = + let src_dir = Path.Build.drop_build_context_exn dir in + Library.Id.of_stanza ~src_dir lib + in let* local_lib, compile_info = Lib.DB.get_compile_info (Scope.libs scope) - (Library.best_name lib) + library_id ~allow_overlaps:buildable.allow_overlapping_dependencies in let local_lib = Lib.Local.of_lib_exn local_lib in let f () = let* source_modules = - Dir_contents.ocaml dir_contents - >>| Ml_sources.modules ~for_:(Library (Library.best_name lib)) + Dir_contents.ocaml dir_contents >>| Ml_sources.modules ~for_:(Library library_id) in let* cctx = cctx lib ~sctx ~source_modules ~dir ~scope ~expander ~compile_info in let* () = diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml index 95ff0eb879f..1cc0ca10558 100644 --- a/src/dune_rules/merlin/merlin.ml +++ b/src/dune_rules/merlin/merlin.ml @@ -525,20 +525,24 @@ module Unprocessed = struct (let open Memo.O in let* scope = Scope.DB.find_by_dir (Expander.dir expander) in let libs = Scope.libs scope in - Lib.DB.find libs (Lib_name.of_string "melange") + Lib.DB.find_stanza_id libs (Lib_name.of_string "melange") >>= function - | Some lib -> - let+ libs = - let linking = - Dune_project.implicit_transitive_deps (Scope.project scope) - in - Lib.closure [ lib ] ~linking - |> Resolve.Memo.peek - >>| function - | Ok libs -> libs - | Error _ -> [] - in - Lib.Set.union requires (Lib.Set.of_list libs) + | Some library_id -> + Lib.DB.find libs library_id + >>= (function + | Some lib -> + let+ libs = + let linking = + Dune_project.implicit_transitive_deps (Scope.project scope) + in + Lib.closure [ lib ] ~linking + |> Resolve.Memo.peek + >>| function + | Ok libs -> libs + | Error _ -> [] + in + Lib.Set.union requires (Lib.Set.of_list libs) + | None -> Memo.return requires) | None -> Memo.return requires) in let+ flags = flags diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index 20814fe14d8..fea8d586789 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -25,7 +25,7 @@ module Modules = struct type component = Modules.t * Path.Build.t Obj_dir.t type t = - { libraries : component Lib_name.Map.t + { libraries : component Library.Id.Map.t ; executables : component String.Map.t ; melange_emits : component String.Map.t ; (* Map from modules to the origin they are part of *) @@ -33,7 +33,7 @@ module Modules = struct } let empty = - { libraries = Lib_name.Map.empty + { libraries = Library.Id.Map.empty ; executables = String.Map.empty ; melange_emits = String.Map.empty ; rev_map = Module_name.Path.Map.empty @@ -53,19 +53,23 @@ module Modules = struct ; melange_emits : Melange_stanzas.Emit.t group_part list } - let make { libraries = libs; executables = exes; melange_emits = emits } = + let make ~dir { libraries = libs; executables = exes; melange_emits = emits } = let libraries = match - Lib_name.Map.of_list_map libs ~f:(fun part -> - Library.best_name part.stanza, (part.modules, part.obj_dir)) + Library.Id.Map.of_list_map libs ~f:(fun part -> + let library_id = + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + Library.Id.of_stanza ~src_dir part.stanza + in + library_id, (part.modules, part.obj_dir)) with | Ok x -> x - | Error (name, _, part) -> + | Error (lib, _, part) -> User_error.raise ~loc:part.stanza.buildable.loc [ Pp.textf "Library %S appears for the second time in this directory" - (Lib_name.to_string name) + (Lib_name.to_string (Library.Id.name lib)) ] in let executables = @@ -214,14 +218,14 @@ let modules_of_files ~path ~dialects ~dir ~files = ;; type for_ = - | Library of Lib_name.t + | Library of Library.Id.t | Exe of { first_exe : string } | Melange of { target : string } let dyn_of_for_ = let open Dyn in function - | Library n -> variant "Library" [ Lib_name.to_dyn n ] + | Library n -> variant "Library" [ Library.Id.to_dyn n ] | Exe { first_exe } -> variant "Exe" [ record [ "first_exe", string first_exe ] ] | Melange { target } -> variant "Melange" [ record [ "target", string target ] ] ;; @@ -229,7 +233,7 @@ let dyn_of_for_ = let modules_and_obj_dir t ~for_ = match match for_ with - | Library name -> Lib_name.Map.find t.modules.libraries name + | Library library_id -> Library.Id.Map.find t.modules.libraries library_id | Exe { first_exe } -> String.Map.find t.modules.executables first_exe | Melange { target } -> String.Map.find t.modules.melange_emits target with @@ -237,7 +241,7 @@ let modules_and_obj_dir t ~for_ = | None -> let map = match for_ with - | Library _ -> Lib_name.Map.keys t.modules.libraries |> Dyn.list Lib_name.to_dyn + | Library _ -> Library.Id.Map.keys t.modules.libraries |> Dyn.list Library.Id.to_dyn | Exe _ -> String.Map.keys t.modules.executables |> Dyn.(list string) | Melange _ -> String.Map.keys t.modules.melange_emits |> Dyn.(list string) in @@ -257,7 +261,7 @@ let virtual_modules ~lookup_vlib vlib = | Local -> let src_dir = Lib_info.src_dir info |> Path.as_in_build_dir_exn in let+ t = lookup_vlib ~dir:src_dir in - modules t ~for_:(Library (Lib.name vlib)) + modules t ~for_:(Library (Lib.library_id vlib)) in let existing_virtual_modules = Modules_group.virtual_module_names modules in let allow_new_public_modules = @@ -307,8 +311,11 @@ let make_lib_modules let open Memo.O in let* resolved = let* libs = libs in - Library.best_name lib - |> Lib.DB.find_even_when_hidden libs + let library_id = + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + Library.Id.of_stanza ~src_dir lib + in + Lib.DB.find_even_when_hidden libs library_id (* can't happen because this library is defined using the current stanza *) >>| Option.value_exn @@ -564,7 +571,7 @@ let make ~modules ~include_subdirs:(loc_include_subdirs, include_subdirs) in - let modules = Modules.make modules_of_stanzas in + let modules = Modules.make ~dir modules_of_stanzas in let artifacts = Memo.lazy_ (fun () -> let libs = diff --git a/src/dune_rules/ml_sources.mli b/src/dune_rules/ml_sources.mli index 0eb62dce0c5..199f344afbe 100644 --- a/src/dune_rules/ml_sources.mli +++ b/src/dune_rules/ml_sources.mli @@ -20,7 +20,7 @@ type t val artifacts : t -> Artifacts_obj.t Memo.t type for_ = - | Library of Lib_name.t (** Library name *) + | Library of Library.Id.t | Exe of { first_exe : string (** Name of first executable appearing in executables stanza *) } diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index 5b8f5b91394..6e32a2048c4 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -583,7 +583,7 @@ let libs_of_pkg ctx ~pkg = List.filter_map entries ~f:(fun (entry : Scope.DB.Lib_entry.t) -> match entry with | Deprecated_library_name _ -> None - | Library lib -> + | Library (_, lib) -> (match Lib.Local.to_lib lib |> Lib.info |> Lib_info.implements with | None -> Some lib | Some _ -> None)) @@ -950,8 +950,9 @@ let setup_private_library_doc_alias sctx ~scope ~dir (l : Library.t) = | Private _ -> let ctx = Super_context.context sctx in let* lib = - Lib.DB.find_even_when_hidden (Scope.libs scope) (Library.best_name l) - >>| Option.value_exn + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + let library_id = Library.Id.of_stanza ~src_dir l in + Lib.DB.find_even_when_hidden (Scope.libs scope) library_id >>| Option.value_exn in let lib = Lib (Lib.Local.of_lib_exn lib) in Rules.Produce.Alias.add_deps @@ -1005,8 +1006,12 @@ let gen_rules sctx ~dir rest = let* lib, lib_db = Scope_key.of_string (Context.name ctx) lib_unique_name_or_pkg in (* jeremiedimino: why isn't [None] some kind of error here? *) let* lib = - let+ lib = Lib.DB.find lib_db lib in - Option.bind ~f:Lib.Local.of_lib lib + let* library_id = Lib.DB.find_stanza_id lib_db lib in + match library_id with + | None -> Memo.return None + | Some library_id -> + let+ lib = Lib.DB.find lib_db library_id in + Option.bind ~f:Lib.Local.of_lib lib in let+ () = match lib with @@ -1036,8 +1041,12 @@ let gen_rules sctx ~dir rest = let* lib, lib_db = Scope_key.of_string (Context.name ctx) lib_unique_name_or_pkg in (* jeremiedimino: why isn't [None] some kind of error here? *) let* lib = - let+ lib = Lib.DB.find lib_db lib in - Option.bind ~f:Lib.Local.of_lib lib + let* library_id = Lib.DB.find_stanza_id lib_db lib in + match library_id with + | None -> Memo.return None + | Some library_id -> + let+ lib = Lib.DB.find lib_db library_id in + Option.bind ~f:Lib.Local.of_lib lib in let+ () = match lib with diff --git a/src/dune_rules/odoc_new.ml b/src/dune_rules/odoc_new.ml index f740f693440..33239431fac 100644 --- a/src/dune_rules/odoc_new.ml +++ b/src/dune_rules/odoc_new.ml @@ -15,7 +15,8 @@ type ext_loc_maps = let stdlib_lib ctx = let* public_libs = Scope.DB.public_libs ctx in - Lib.DB.find public_libs (Lib_name.of_string "stdlib") + let* library_id = Lib.DB.find_stanza_id public_libs (Lib_name.of_string "stdlib") in + Lib.DB.find public_libs (Option.value_exn library_id) ;; let lib_equal l1 l2 = Lib.compare l1 l2 |> Ordering.is_eq @@ -265,8 +266,9 @@ let libs_maps_def = | Some location -> let info = Dune_package.Lib.info l in let name = Lib_info.name info in + let lib_id = Dune_package.Lib.library_id l in let pkg = Lib_info.package info in - Lib.DB.find db name + Lib.DB.find db lib_id >>| (function | None -> maps | Some lib -> diff --git a/src/dune_rules/scope.ml b/src/dune_rules/scope.ml index 6d5c9e75a31..bdd467270e4 100644 --- a/src/dune_rules/scope.ml +++ b/src/dune_rules/scope.ml @@ -27,7 +27,6 @@ module DB = struct type t = private | Found of Lib_info.external_ | Redirect of (Loc.t * Lib_name.t) * Toggle.t Memo.Lazy.t - | Many of t list | Deprecated_library_name of (Loc.t * Lib_name.t) val redirect @@ -36,14 +35,12 @@ module DB = struct -> Loc.t * Lib_name.t -> Lib_name.t * t - val many : t list -> t val deprecated_library_name : Lib_name.t -> Loc.t * Lib_name.t -> Lib_name.t * t val found : Lib_info.external_ -> t end = struct type t = | Found of Lib_info.external_ | Redirect of (Loc.t * Lib_name.t) * Toggle.t Memo.Lazy.t - | Many of t list | Deprecated_library_name of (Loc.t * Lib_name.t) let redirect ~enabled from (loc, to_) = @@ -52,8 +49,6 @@ module DB = struct else from, Redirect ((loc, to_), enabled) ;; - let many x = Many x - let deprecated_library_name from (loc, to_) = if Lib_name.equal from to_ then Code_error.raise ~loc "Invalid redirect" [ "to_", Lib_name.to_dyn to_ ] @@ -63,79 +58,78 @@ module DB = struct let found x = Found x end + let find_stanza_id id_map name = + Memo.return + @@ + match Lib_name.Map.find id_map name with + | None | Some [] -> [] + | Some xs -> xs + ;; + module Library_related_stanza = struct type t = | Library of Path.Build.t * Library.t | Library_redirect of Path.Build.t * Library_redirect.Local.t - | Deprecated_library_name of Deprecated_library_name.t + | Deprecated_library_name of Path.Build.t * Deprecated_library_name.t end let create_db_from_stanzas ~instrument_with ~parent ~lib_config stanzas = - let map = - List.map stanzas ~f:(fun stanza -> - match (stanza : Library_related_stanza.t) with - | Library_redirect (dir, s) -> - let old_public_name = Lib_name.of_local s.old_name.lib_name in - let enabled = - Memo.lazy_ (fun () -> - let open Memo.O in - let* expander = Expander0.get ~dir in - let+ enabled = Expander0.eval_blang expander s.old_name.enabled in - Toggle.of_bool enabled) - in - Found_or_redirect.redirect ~enabled old_public_name s.new_public_name - | Deprecated_library_name s -> - let old_public_name = Deprecated_library_name.old_public_name s in - Found_or_redirect.deprecated_library_name old_public_name s.new_public_name - | Library (dir, (conf : Library.t)) -> - let info = - let expander = Expander0.get ~dir in - Library.to_lib_info conf ~expander ~dir ~lib_config |> Lib_info.of_local - in - Library.best_name conf, Found_or_redirect.found info) - |> Lib_name.Map.of_list_reducei ~f:(fun name (v1 : Found_or_redirect.t) v2 -> - let res = - match v1, v2 with - | Found _, Found _ - | Found _, Redirect _ - | Redirect _, Found _ - | Redirect _, Redirect _ -> Ok (Found_or_redirect.many [ v1; v2 ]) - | Found info, Deprecated_library_name (loc, _) - | Deprecated_library_name (loc, _), Found info -> Error (loc, Lib_info.loc info) - | Deprecated_library_name (loc2, lib2), Redirect ((loc1, lib1), _) - | Redirect ((loc1, lib1), _), Deprecated_library_name (loc2, lib2) -> - if Lib_name.equal lib1 lib2 then Ok v1 else Error (loc1, loc2) - | Deprecated_library_name (loc1, lib1), Deprecated_library_name (loc2, lib2) -> - if Lib_name.equal lib1 lib2 then Ok v1 else Error (loc1, loc2) - | Many _, _ | _, Many _ -> assert false - in - match res with - | Ok x -> x - | Error (loc1, loc2) -> - let main_message = - Pp.textf "Library %s is defined twice:" (Lib_name.to_string name) - in - let annots = - let main = User_message.make ~loc:loc2 [ main_message ] in - let related = - [ User_message.make ~loc:loc1 [ Pp.text "Already defined here" ] ] + let map, id_map = + let libs = + List.map stanzas ~f:(fun stanza -> + match (stanza : Library_related_stanza.t) with + | Library_redirect (dir, s) -> + let old_public_name = Lib_name.of_local s.old_name.lib_name in + let enabled = + Memo.lazy_ (fun () -> + let open Memo.O in + let* expander = Expander0.get ~dir in + let+ enabled = Expander0.eval_blang expander s.old_name.enabled in + Toggle.of_bool enabled) in - User_message.Annots.singleton - Compound_user_error.annot - [ Compound_user_error.make ~main ~related ] - in - User_error.raise - ~annots - [ main_message - ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) - ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) - ]) + let lib_name, redirect = + Found_or_redirect.redirect ~enabled old_public_name s.new_public_name + in + let library_id = + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + ( Library.Id.make ~loc:s.loc ~src_dir ~enabled_if:s.old_name.enabled lib_name + , redirect ) + in + lib_name, library_id + | Deprecated_library_name (dir, s) -> + let old_public_name = Deprecated_library_name.old_public_name s in + let lib_name, deprecated_lib = + Found_or_redirect.deprecated_library_name old_public_name s.new_public_name + in + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + lib_name, (Deprecated_library_name.to_id ~src_dir s, deprecated_lib) + | Library (dir, (conf : Library.t)) -> + let info = + let expander = Expander0.get ~dir in + Library.to_lib_info conf ~expander ~dir ~lib_config |> Lib_info.of_local + in + let stanza_id = + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + Library.Id.of_stanza ~src_dir conf + in + Library.best_name conf, (stanza_id, Found_or_redirect.found info)) + in + let id_map = + let libs = List.map libs ~f:(fun (name, (id, _lib)) -> name, id) in + Lib_name.Map.of_list_multi libs + and map = + let libs = List.map libs ~f:snd in + Library.Id.Map.of_list_exn libs + in + map, id_map in + let find_stanza_id = find_stanza_id id_map in Lib.DB.create () ~parent:(Some parent) - ~resolve:(fun name -> - match Lib_name.Map.find map name with + ~find_stanza_id + ~resolve:(fun library_id -> + match Library.Id.Map.find map library_id with | None -> Memo.return Lib.DB.Resolve_result.not_found | Some (Redirect (lib, enabled)) -> let+ enabled = @@ -146,42 +140,26 @@ module DB = struct then Lib.DB.Resolve_result.redirect_in_the_same_db lib else Lib.DB.Resolve_result.not_found | Some (Found lib) -> Memo.return (Lib.DB.Resolve_result.found lib) - | Some (Many libs) -> - let+ results = - Memo.List.filter_map - ~f:(function - | Found_or_redirect.Redirect (lib, enabled) -> - let+ enabled = - let+ toggle = Memo.Lazy.force enabled in - Toggle.enabled toggle - in - if enabled - then Some (Lib.DB.Resolve_result.redirect_in_the_same_db lib) - else None - | Found lib -> Memo.return (Some (Lib.DB.Resolve_result.found lib)) - | Deprecated_library_name lib -> - Memo.return (Some (Lib.DB.Resolve_result.deprecated_library_name lib)) - | Many _ -> assert false) - libs - in - Lib.DB.Resolve_result.multiple_results results | Some (Deprecated_library_name lib) -> Memo.return (Lib.DB.Resolve_result.deprecated_library_name lib)) - ~all:(fun () -> Memo.return @@ Lib_name.Map.keys map) + ~all:(fun () -> Memo.return @@ Library.Id.Map.keys map) ~lib_config ~instrument_with ;; type redirect_to = - | Project of Dune_project.t + | Project of + { project : Dune_project.t + ; library_id : Library.Id.t + } | Name of (Loc.t * Lib_name.t) - let resolve t public_libs name : Lib.DB.Resolve_result.t = - match Lib_name.Map.find public_libs name with + let resolve t public_libs library_id : Lib.DB.Resolve_result.t = + match Library.Id.Map.find public_libs library_id with | None -> Lib.DB.Resolve_result.not_found - | Some (Project project) -> + | Some (Project { project; library_id }) -> let scope = find_by_project (Fdecl.get t) project in - Lib.DB.Resolve_result.redirect scope.db (Loc.none, name) + Lib.DB.Resolve_result.redirect scope.db library_id | Some (Name name) -> Lib.DB.Resolve_result.redirect_in_the_same_db name ;; @@ -195,56 +173,97 @@ module DB = struct (* Create a database from the public libraries defined in the stanzas *) let public_libs t ~installed_libs ~lib_config stanzas = - let public_libs = - match - List.filter_map stanzas ~f:(fun (stanza : Library_related_stanza.t) -> - match stanza with - | Library (_, { project; visibility = Public p; _ }) -> - Some (Public_lib.name p, Project project) - | Library _ | Library_redirect _ -> None - | Deprecated_library_name s -> - let old_name = Deprecated_library_name.old_public_name s in - Some (old_name, Name s.new_public_name)) - |> Lib_name.Map.of_list - with - | Ok x -> x - | Error (name, _, _) -> - (match - List.filter_map stanzas ~f:(fun stanza -> - let named p loc = Option.some_if (name = p) loc in - match stanza with - | Library (_, { buildable = { loc; _ }; visibility = Public p; _ }) - | Deprecated_library_name { Library_redirect.loc; old_name = p, _; _ } -> - named (Public_lib.name p) loc - | _ -> None) - with - | [] | [ _ ] -> assert false - | loc1 :: loc2 :: _ -> - let main_message = - Pp.textf "Public library %s is defined twice:" (Lib_name.to_string name) - in - let annots = - let main = User_message.make ~loc:loc2 [ main_message ] in - let related = - [ User_message.make ~loc:loc1 [ Pp.text "Already defined here" ] ] + let public_libs, public_ids = + let public_libs, public_ids = + let libs = + List.filter_map stanzas ~f:(fun (stanza : Library_related_stanza.t) -> + match stanza with + | Library (dir, ({ project; visibility = Public p; _ } as conf)) -> + let library_id = + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + Library.Id.of_stanza ~src_dir conf + in + Some (Public_lib.name p, Project { project; library_id }, library_id) + | Library _ | Library_redirect _ -> None + | Deprecated_library_name (dir, s) -> + let old_name = Deprecated_library_name.old_public_name s in + let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in + Some + ( old_name + , Name s.new_public_name + , Deprecated_library_name.to_id ~src_dir s )) + in + List.fold_left + libs + ~init:([], []) + ~f:(fun (public_libs, public_ids) (name, redirect_to, id) -> + (id, redirect_to) :: public_libs, (name, id) :: public_ids) + in + let public_ids = Lib_name.Map.of_list_multi public_ids + and public_libs = + match Library.Id.Map.of_list public_libs with + | Ok x -> x + | Error (library_id, _, _) -> + (match + List.filter_map stanzas ~f:(fun stanza -> + let named p ~lib_id loc = + Option.some_if + (Library.Id.equal library_id lib_id) + (Public_lib.name p, loc) + in + match stanza with + | Library + (dir, ({ buildable = { loc; _ }; visibility = Public p; _ } as conf)) + -> + let library_id = + let src_dir = + Path.drop_optional_build_context_src_exn (Path.build dir) + in + Library.Id.of_stanza ~src_dir conf + in + named p ~lib_id:library_id loc + | Deprecated_library_name + (dir, ({ Library_redirect.loc; old_name = p, _; _ } as conf)) -> + let library_id = + let src_dir = + Path.drop_optional_build_context_src_exn (Path.build dir) + in + Deprecated_library_name.to_id ~src_dir conf + in + named p ~lib_id:library_id loc + | _ -> None) + with + | [] | [ _ ] -> assert false + | (name, loc1) :: (_, loc2) :: _ -> + let main_message = + Pp.textf "Public library %s is defined twice:" (Lib_name.to_string name) + in + let annots = + let main = User_message.make ~loc:loc2 [ main_message ] in + let related = + [ User_message.make ~loc:loc1 [ Pp.text "Already defined here" ] ] + in + User_message.Annots.singleton + Compound_user_error.annot + [ Compound_user_error.make ~main ~related ] in - User_message.Annots.singleton - Compound_user_error.annot - [ Compound_user_error.make ~main ~related ] - in - User_error.raise - ~annots - ~loc:loc2 - [ Pp.textf "Public library %s is defined twice:" (Lib_name.to_string name) - ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) - ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) - ]) + User_error.raise + ~annots + ~loc:loc2 + [ Pp.textf "Public library %s is defined twice:" (Lib_name.to_string name) + ; Pp.textf "- %s" (Loc.to_file_colon_line loc1) + ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) + ]) + in + public_libs, public_ids in - let resolve lib = Memo.return (resolve t public_libs lib) in + let resolve lib = Memo.return (resolve t public_libs lib) + and find_stanza_id = find_stanza_id public_ids in Lib.DB.create ~parent:(Some installed_libs) + ~find_stanza_id ~resolve - ~all:(fun () -> Lib_name.Map.keys public_libs |> Memo.return) + ~all:(fun () -> Library.Id.Map.keys public_libs |> Memo.return) ~lib_config () ;; @@ -293,7 +312,7 @@ module DB = struct match stanza with | Library (_, lib) -> lib.project | Library_redirect (_, x) -> x.project - | Deprecated_library_name x -> x.project + | Deprecated_library_name (_, x) -> x.project in Dune_project.root project, stanza) |> Path.Source.Map.of_list_multi @@ -377,7 +396,9 @@ module DB = struct | Library.T lib -> let ctx_dir = Path.Build.append_source build_dir (Dune_file.dir dune_file) in Library_related_stanza.Library (ctx_dir, lib) :: acc, coq_acc - | Deprecated_library_name.T d -> Deprecated_library_name d :: acc, coq_acc + | Deprecated_library_name.T d -> + let ctx_dir = Path.Build.append_source build_dir (Dune_file.dir dune_file) in + Deprecated_library_name (ctx_dir, d) :: acc, coq_acc | Library_redirect.Local.T d -> let ctx_dir = Path.Build.append_source build_dir (Dune_file.dir dune_file) in Library_redirect (ctx_dir, d) :: acc, coq_acc @@ -425,11 +446,11 @@ module DB = struct module Lib_entry = struct type t = - | Library of Lib.Local.t + | Library of Library.Id.t * Lib.Local.t | Deprecated_library_name of Deprecated_library_name.t let name = function - | Library lib -> Lib.Local.to_lib lib |> Lib.name + | Library (_, lib) -> Lib.Local.to_lib lib |> Lib.name | Deprecated_library_name { old_name = old_public_name, _; _ } -> Public_lib.name old_public_name ;; @@ -441,29 +462,37 @@ module DB = struct Dune_file.Memo_fold.fold_static_stanzas stanzas ~init:[] ~f:(fun d stanza acc -> match Stanza.repr stanza with | Library.T ({ visibility = Private (Some pkg); _ } as lib) -> + let src_dir = Dune_file.dir d in + let library_id = Library.Id.of_stanza ~src_dir lib in let+ lib = - let* scope = - find_by_dir (Path.Build.append_source build_dir (Dune_file.dir d)) - in - let db = libs scope in - Lib.DB.find db (Library.best_name lib) + let* scope = find_by_dir (Path.Build.append_source build_dir src_dir) in + Lib.DB.find (libs scope) library_id in (match lib with | None -> acc | Some lib -> let name = Package.name pkg in - (name, Lib_entry.Library (Lib.Local.of_lib_exn lib)) :: acc) - | Library.T { visibility = Public pub; _ } -> - let+ lib = Lib.DB.find public_libs (Public_lib.name pub) in + (name, Lib_entry.Library (library_id, Lib.Local.of_lib_exn lib)) :: acc) + | Library.T ({ visibility = Public pub; _ } as conf) -> + let library_id = + let src_dir = Dune_file.dir d in + Library.Id.of_stanza ~src_dir conf + in + let* lib = Lib.DB.find_stanza_id public_libs (Public_lib.name pub) in (match lib with | None -> (* Skip hidden or unavailable libraries. TODO we should assert that the library name is always found somehow *) - acc - | Some lib -> - let package = Public_lib.package pub in - let name = Package.name package in - (name, Lib_entry.Library (Lib.Local.of_lib_exn lib)) :: acc) + Memo.return acc + | Some lib_id -> + let+ lib = Lib.DB.find public_libs lib_id in + (match lib with + | None -> acc + | Some lib -> + let package = Public_lib.package pub in + let name = Package.name package in + let local_lib = Lib.Local.of_lib_exn lib in + (name, Lib_entry.Library (library_id, local_lib)) :: acc)) | Deprecated_library_name.T ({ old_name = old_public_name, _; _ } as d) -> let package = Public_lib.package old_public_name in let name = Package.name package in diff --git a/src/dune_rules/scope.mli b/src/dune_rules/scope.mli index 58f20daffb9..1ed0fdd7dd6 100644 --- a/src/dune_rules/scope.mli +++ b/src/dune_rules/scope.mli @@ -22,7 +22,7 @@ module DB : sig module Lib_entry : sig type t = - | Library of Lib.Local.t + | Library of Library.Id.t * Lib.Local.t | Deprecated_library_name of Deprecated_library_name.t end diff --git a/src/dune_rules/stanzas/deprecated_library_name.ml b/src/dune_rules/stanzas/deprecated_library_name.ml index 99ff37ccb73..c541173efe0 100644 --- a/src/dune_rules/stanzas/deprecated_library_name.ml +++ b/src/dune_rules/stanzas/deprecated_library_name.ml @@ -47,3 +47,11 @@ let decode = in { Library_redirect.loc; project; old_name; new_public_name }) ;; + +let to_id ~src_dir (t : t) = + let loc, name = + let lib, _ = t.old_name in + Public_lib.loc lib, Public_lib.name lib + and enabled_if = Blang.true_ in + Library.Id.make ~loc ~src_dir ~enabled_if name +;; diff --git a/src/dune_rules/stanzas/deprecated_library_name.mli b/src/dune_rules/stanzas/deprecated_library_name.mli index b4a1e15490a..6e14b89fbe5 100644 --- a/src/dune_rules/stanzas/deprecated_library_name.mli +++ b/src/dune_rules/stanzas/deprecated_library_name.mli @@ -15,3 +15,4 @@ val decode : t Dune_lang.Decoder.t include Stanza.S with type t := t val old_public_name : t -> Lib_name.t +val to_id : src_dir:Path.Source.t -> t -> Library.Id.t diff --git a/src/dune_rules/stanzas/library.ml b/src/dune_rules/stanzas/library.ml index 274147fe5a5..10f697fc69a 100644 --- a/src/dune_rules/stanzas/library.ml +++ b/src/dune_rules/stanzas/library.ml @@ -579,3 +579,72 @@ include Stanza.Make (struct include Poly end) + +module Id = struct + type stanza = t + + module T = struct + type t = + { name : Lib_name.t + ; loc : Loc.t + ; src_dir : Path.t + ; enabled_if : Blang.t + } + + let compare a b = + match Lib_name.compare a.name b.name with + | Eq -> + (match Path.compare a.src_dir b.src_dir with + | Eq -> + (match Loc.compare a.loc b.loc with + | Eq -> + assert (Blang.equal a.enabled_if b.enabled_if); + Eq + | o -> o) + | o -> o) + | x -> x + ;; + + let to_dyn { name; loc; enabled_if; src_dir } = + let open Dyn in + record + [ "name", Lib_name.to_dyn name + ; "loc", Loc.to_dyn_hum loc + ; "src_dir", Path.to_dyn src_dir + ; "enabled_if", Blang.to_dyn enabled_if + ] + ;; + + let equal a b = + match compare a b with + | Eq -> true + | Lt | Gt -> false + ;; + end + + module O = Comparable.Make (T) + module Map = O.Map + include T + + let external_ ~loc ~src_dir ~enabled_if name = { name; loc; enabled_if; src_dir } + + let make ~loc ~src_dir ~enabled_if name = + let src_dir = Path.source src_dir in + { name; loc; enabled_if; src_dir } + ;; + + let name { name; _ } = name + let loc { loc; _ } = loc + (* let src_dir { src_dir; _ } = src_dir *) + + let of_stanza ~src_dir (lib : stanza) = + let loc, name = + let ((loc, _) as name) = lib.name in + loc, Lib_name.of_local name + in + let enabled_if = lib.enabled_if in + make ~loc ~src_dir ~enabled_if name + ;; + + (* val of_stanza : Library.t -> t *) +end diff --git a/src/dune_rules/stanzas/library.mli b/src/dune_rules/stanzas/library.mli index 5dd1360ea57..24a65575bc6 100644 --- a/src/dune_rules/stanzas/library.mli +++ b/src/dune_rules/stanzas/library.mli @@ -84,3 +84,21 @@ val to_lib_info -> dir:Path.Build.t -> lib_config:Lib_config.t -> Lib_info.local + +(** What's the subset of fields that uniquely identifies this stanza? *) +module Id : sig + type stanza := t + type t + + module Map : Map.S with type key = t + + val equal : t -> t -> bool + val make : loc:Loc.t -> src_dir:Path.Source.t -> enabled_if:Blang.t -> Lib_name.t -> t + val external_ : loc:Loc.t -> src_dir:Path.t -> enabled_if:Blang.t -> Lib_name.t -> t + val name : t -> Lib_name.t + val loc : t -> Loc.t + + (* val src_dir : t -> Path.Source.t *) + val of_stanza : src_dir:Path.Source.t -> stanza -> t + val to_dyn : t -> Dyn.t +end diff --git a/src/dune_rules/virtual_rules.ml b/src/dune_rules/virtual_rules.ml index 866e4be43ca..cfeeee7ea12 100644 --- a/src/dune_rules/virtual_rules.ml +++ b/src/dune_rules/virtual_rules.ml @@ -56,7 +56,8 @@ let impl sctx ~(lib : Library.t) ~scope = match lib.implements with | None -> Memo.return None | Some (loc, implements) -> - Lib.DB.find (Scope.libs scope) implements + let db = Scope.libs scope in + Lib.DB.find_stanza_id db implements >>= (function | None -> User_error.raise @@ -65,60 +66,69 @@ let impl sctx ~(lib : Library.t) ~scope = "Cannot implement %s as that library isn't available" (Lib_name.to_string implements) ] - | Some vlib -> - let info = Lib.info vlib in - let virtual_ = - let virtual_ = Lib_info.virtual_ info in - match virtual_ with - | Some v -> v - | None -> - User_error.raise - ~loc:lib.buildable.loc - [ Pp.textf - "Library %s isn't virtual and cannot be implemented" - (Lib_name.to_string implements) - ] - in - let+ vlib_modules, vlib_foreign_objects = - let foreign_objects = Lib_info.foreign_objects info in - match virtual_, foreign_objects with - | External _, Local | Local, External _ -> assert false - | External modules, External fa -> Memo.return (modules, fa) - | Local, Local -> - let name = Lib.name vlib in - let vlib = Lib.Local.of_lib_exn vlib in - let* dir_contents = - let info = Lib.Local.info vlib in - let dir = Lib_info.src_dir info in - Dir_contents.get sctx ~dir - in - let* ocaml = Context.ocaml (Super_context.context sctx) in - let* modules = - let* preprocess = - (* TODO wrong, this should be delayed *) - Resolve.Memo.read_memo - (Preprocess.Per_module.with_instrumentation - lib.buildable.preprocess - ~instrumentation_backend: - (Lib.DB.instrumentation_backend (Scope.libs scope))) - in - let pp_spec = - Staged.unstage (Preprocessing.pped_modules_map preprocess ocaml.version) - in - Dir_contents.ocaml dir_contents - >>| Ml_sources.modules ~for_:(Library name) - >>= Modules.map_user_written ~f:(fun m -> Memo.return (pp_spec m)) - in - let+ foreign_objects = - let ext_obj = ocaml.lib_config.ext_obj in - let dir = Obj_dir.obj_dir (Lib.Local.obj_dir vlib) in - let+ foreign_sources = Dir_contents.foreign_sources dir_contents in - foreign_sources - |> Foreign_sources.for_lib ~name - |> Foreign.Sources.object_files ~ext_obj ~dir - |> List.map ~f:Path.build - in - modules, foreign_objects - in - Some (Vimpl.make ~impl:lib ~vlib ~vlib_modules ~vlib_foreign_objects)) + | Some library_id -> + Lib.DB.find db library_id + >>= (function + | None -> + User_error.raise + ~loc + [ Pp.textf + "Cannot implement %s as that library isn't available" + (Lib_name.to_string implements) + ] + | Some vlib -> + let info = Lib.info vlib in + let virtual_ = + let virtual_ = Lib_info.virtual_ info in + match virtual_ with + | Some v -> v + | None -> + User_error.raise + ~loc:lib.buildable.loc + [ Pp.textf + "Library %s isn't virtual and cannot be implemented" + (Lib_name.to_string implements) + ] + in + let+ vlib_modules, vlib_foreign_objects = + let foreign_objects = Lib_info.foreign_objects info in + match virtual_, foreign_objects with + | External _, Local | Local, External _ -> assert false + | External modules, External fa -> Memo.return (modules, fa) + | Local, Local -> + let vlib = Lib.Local.of_lib_exn vlib in + let* dir_contents = + let info = Lib.Local.info vlib in + let dir = Lib_info.src_dir info in + Dir_contents.get sctx ~dir + in + let* ocaml = Context.ocaml (Super_context.context sctx) in + let* modules = + let* preprocess = + (* TODO wrong, this should be delayed *) + Resolve.Memo.read_memo + (Preprocess.Per_module.with_instrumentation + lib.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope))) + in + let pp_spec = + Staged.unstage (Preprocessing.pped_modules_map preprocess ocaml.version) + in + Dir_contents.ocaml dir_contents + >>| Ml_sources.modules ~for_:(Library library_id) + >>= Modules.map_user_written ~f:(fun m -> Memo.return (pp_spec m)) + in + let+ foreign_objects = + let ext_obj = ocaml.lib_config.ext_obj in + let dir = Obj_dir.obj_dir (Lib.Local.obj_dir vlib) in + let+ foreign_sources = Dir_contents.foreign_sources dir_contents in + foreign_sources + |> Foreign_sources.for_lib ~library_id + |> Foreign.Sources.object_files ~ext_obj ~dir + |> List.map ~f:Path.build + in + modules, foreign_objects + in + Some (Vimpl.make ~impl:lib ~vlib ~vlib_modules ~vlib_foreign_objects))) ;; diff --git a/test/blackbox-tests/test-cases/lib-collision/lib-collision-private-same-folder.t b/test/blackbox-tests/test-cases/lib-collision/lib-collision-private-same-folder.t index 434f4c01ecb..9c7391ac9d9 100644 --- a/test/blackbox-tests/test-cases/lib-collision/lib-collision-private-same-folder.t +++ b/test/blackbox-tests/test-cases/lib-collision/lib-collision-private-same-folder.t @@ -15,12 +15,10 @@ the same folder. Without any consumers of the libraries $ dune build - File "dune", line 1, characters 0-21: - 1 | (library - 2 | (name foo)) - Error: A library with name "foo" is defined in two folders: _build/default - and _build/default. Either change one of the names, or enable them - conditionally using the 'enabled_if' field. + File "dune", line 3, characters 0-21: + 3 | (library + 4 | (name foo)) + Error: Library "foo" appears for the second time in this directory [1] With some consumer of the library @@ -40,12 +38,6 @@ With some consumer of the library > EOF $ dune build - File "dune", line 1, characters 0-21: - 1 | (library - 2 | (name foo)) - Error: A library with name "foo" is defined in two folders: _build/default - and _build/default. Either change one of the names, or enable them - conditionally using the 'enabled_if' field. File "dune", line 3, characters 0-21: 3 | (library 4 | (name foo)) diff --git a/test/blackbox-tests/test-cases/lib-collision/lib-collision-private.t b/test/blackbox-tests/test-cases/lib-collision/lib-collision-private.t index 9c94ebff0f6..8d2ccc1ffc8 100644 --- a/test/blackbox-tests/test-cases/lib-collision/lib-collision-private.t +++ b/test/blackbox-tests/test-cases/lib-collision/lib-collision-private.t @@ -17,16 +17,19 @@ different folders. > (name foo)) > EOF -Without any consumers of the libraries - - $ dune build - File "b/dune", line 1, characters 0-21: - 1 | (library - 2 | (name foo)) - Error: A library with name "foo" is defined in two folders: _build/default/a - and _build/default/b. Either change one of the names, or enable them - conditionally using the 'enabled_if' field. - [1] +Without any consumers of the libraries (both are built in separate folders) + + $ dune build --display short + ocamlc a/.foo.objs/byte/foo.{cmi,cmo,cmt} + ocamlc b/.foo.objs/byte/foo.{cmi,cmo,cmt} + ocamlopt a/.foo.objs/native/foo.{cmx,o} + ocamlc a/foo.cma + ocamlopt b/.foo.objs/native/foo.{cmx,o} + ocamlc b/foo.cma + ocamlopt a/foo.{a,cmxa} + ocamlopt b/foo.{a,cmxa} + ocamlopt a/foo.cmxs + ocamlopt b/foo.cmxs With some consumer of the library diff --git a/test/blackbox-tests/test-cases/lib-collision/lib-collision-public-same-folder.t b/test/blackbox-tests/test-cases/lib-collision/lib-collision-public-same-folder.t index d7d514fa7c5..3e8af8c0fb3 100644 --- a/test/blackbox-tests/test-cases/lib-collision/lib-collision-public-same-folder.t +++ b/test/blackbox-tests/test-cases/lib-collision/lib-collision-public-same-folder.t @@ -19,13 +19,9 @@ the same folder. Without any consumers of the libraries $ dune build - File "dune", line 1, characters 0-44: - 1 | (library - 2 | (name foo) - 3 | (public_name bar.foo)) - Error: A library with name "foo" is defined in two folders: _build/default - and _build/default. Either change one of the names, or enable them - conditionally using the 'enabled_if' field. + Error: Multiple rules generated for _build/default/foo.cmxs: + - dune:4 + - dune:1 [1] With some consumer @@ -56,11 +52,4 @@ With some consumer library, executable, and executables stanzas in this dune file. Note that each module cannot appear in more than one "modules" field - it must belong to a single library or executable. - File "dune", line 1, characters 0-44: - 1 | (library - 2 | (name foo) - 3 | (public_name bar.foo)) - Error: A library with name "foo" is defined in two folders: _build/default - and _build/default. Either change one of the names, or enable them - conditionally using the 'enabled_if' field. [1] diff --git a/test/blackbox-tests/test-cases/lib-collision/lib-collision-public.t b/test/blackbox-tests/test-cases/lib-collision/lib-collision-public.t index 3827b536bcf..9821639da72 100644 --- a/test/blackbox-tests/test-cases/lib-collision/lib-collision-public.t +++ b/test/blackbox-tests/test-cases/lib-collision/lib-collision-public.t @@ -24,14 +24,6 @@ different folders. Without any consumers of the libraries $ dune build - File "b/dune", line 1, characters 0-44: - 1 | (library - 2 | (name foo) - 3 | (public_name baz.foo)) - Error: A library with name "foo" is defined in two folders: _build/default/a - and _build/default/b. Either change one of the names, or enable them - conditionally using the 'enabled_if' field. - [1] With some consumer