diff --git a/src/lib.ml b/src/lib.ml index ce3ba6d9..34fd9f84 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -189,6 +189,8 @@ let plugins t = t.info.plugins let jsoo_runtime t = t.info.jsoo_runtime let unique_id t = t.unique_id +let virtual_ t = t.info.virtual_ + let dune_version t = t.info.dune_version let src_dir t = t.info.src_dir diff --git a/src/lib.mli b/src/lib.mli index c414103e..e2725d4d 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -27,6 +27,8 @@ val archives : t -> Path.t list Mode.Dict.t val plugins : t -> Path.t list Mode.Dict.t val jsoo_runtime : t -> Path.t list +val virtual_ : t -> Lib_info.Virtual.t option + val dune_version : t -> Syntax.Version.t option (** A unique integer identifier. It is only unique for the duration of diff --git a/src/lib_name.ml b/src/lib_name.ml index bdc1231a..99f235d8 100644 --- a/src/lib_name.ml +++ b/src/lib_name.ml @@ -53,6 +53,7 @@ module Local = struct let to_sexp = Sexp.To_sexp.string let pp_quoted fmt t = Format.fprintf fmt "%S" t + let pp fmt t = Format.fprintf fmt "%s" t let invalid_message = "invalid library name.\n\ diff --git a/src/lib_name.mli b/src/lib_name.mli index 0e4124e2..f3322b96 100644 --- a/src/lib_name.mli +++ b/src/lib_name.mli @@ -30,6 +30,7 @@ module Local : sig val invalid_message : string val pp_quoted : t Fmt.t + val pp : t Fmt.t end val compare : t -> t -> Ordering.t diff --git a/src/lib_rules.ml b/src/lib_rules.ml index 6744d1d9..f5bb216f 100644 --- a/src/lib_rules.ml +++ b/src/lib_rules.ml @@ -17,6 +17,8 @@ module Gen (P : Install_rules.Params) = struct let opaque = SC.opaque sctx + module Virtual = Virtual_rules.Gen(P) + (* +-----------------------------------------------------------------+ | Library stuff | +-----------------------------------------------------------------+ *) @@ -358,6 +360,8 @@ module Gen (P : Install_rules.Params) = struct ; virtual_modules = _ } = Dir_contents.modules_of_library dir_contents ~name:(Library.best_name lib) in + let impl = Virtual.impl ~lib ~scope ~modules in + Option.iter impl ~f:(Virtual.setup_copy_rules_for_impl ~dir); let source_modules = modules in (* Preprocess before adding the alias module as it doesn't need preprocessing *) diff --git a/src/module.ml b/src/module.ml index 1dc8ad78..bceb3ac4 100644 --- a/src/module.ml +++ b/src/module.ml @@ -100,6 +100,7 @@ let make ?impl ?intf ?obj_name name = let real_unit_name t = Name.of_string (Filename.basename t.obj_name) let has_impl t = Option.is_some t.impl +let has_intf t = Option.is_some t.intf let file t (kind : Ml_kind.t) = let file = diff --git a/src/module.mli b/src/module.mli index 32a58b0d..97536e1b 100644 --- a/src/module.mli +++ b/src/module.mli @@ -87,6 +87,7 @@ val cmti_file : t -> obj_dir:Path.t -> Path.t val iter : t -> f:(Ml_kind.t -> File.t -> unit) -> unit val has_impl : t -> bool +val has_intf : t -> bool (** Prefix the object name with the library name. *) val with_wrapper : t -> libname:Lib_name.Local.t -> t diff --git a/src/virtual_rules.ml b/src/virtual_rules.ml new file mode 100644 index 00000000..c87f503a --- /dev/null +++ b/src/virtual_rules.ml @@ -0,0 +1,107 @@ +open Import +open! No_io + +module Implementation = struct + type t = + { vlib : Lib.t + ; impl : Dune_file.Library.t + ; vlib_modules : Module.t Module.Name.Map.t + } +end + +module Gen (P : sig val sctx : Super_context.t end) = struct + open P + let ctx = Super_context.context sctx + + let setup_copy_rules_for_impl ~dir + { Implementation.vlib ; impl ; vlib_modules } = + let copy_to_obj_dir = + let obj_dir = Utils.library_object_directory ~dir impl.name in + fun file -> + let dst = Path.relative obj_dir (Path.basename file) in + Super_context.add_rule sctx (Build.symlink ~src:file ~dst) + in + let obj_dir = Lib.obj_dir vlib in + let modes = + Dune_file.Mode_conf.Set.eval impl.modes + ~has_native:(Option.is_some ctx.ocamlopt) in + Module.Name.Map.iter vlib_modules ~f:(fun m -> + let copy_obj_file ext = + copy_to_obj_dir (Module.obj_file m ~obj_dir ~ext) in + copy_obj_file (Cm_kind.ext Cmi); + if Module.has_impl m then begin + if modes.byte then + copy_obj_file (Cm_kind.ext Cmo); + if modes.native then + List.iter [Cm_kind.ext Cmx; ctx.ext_obj] ~f:copy_obj_file + end) + + let impl ~(lib : Dune_file.Library.t) ~scope ~modules = + Option.map lib.implements ~f:begin fun (loc, implements) -> + match Lib.DB.find (Scope.libs scope) implements with + | Error _ -> + Errors.fail loc + "Cannot implement %a as that library isn't available" + Lib_name.pp implements + | Ok vlib -> + let virtual_modules = + Option.map (Lib.virtual_ vlib) ~f:(fun (v : Lib_info.Virtual.t) -> + v.modules) + in + let (vlib_modules, virtual_modules) = + match virtual_modules with + | None -> + Errors.fail lib.buildable.loc + "Library %a isn't virtual and cannot be implemented" + Lib_name.pp implements + | Some Unexpanded -> + let dir_contents = Dir_contents.get sctx ~dir:(Lib.src_dir vlib) in + let { Dir_contents.Library_modules. + virtual_modules + ; modules = vlib_modules + ; main_module_name = _ + ; alias_module = _ + ; wrapped_compat = _ + } = + Dir_contents.modules_of_library dir_contents + ~name:(Lib.name vlib) in + (vlib_modules, virtual_modules) + in + let (missing_modules, impl_modules_with_intf) = + Module.Name.Map.foldi virtual_modules ~init:([], []) + ~f:(fun m _ (mms, ims) -> + match Module.Name.Map.find modules m with + | None -> (m :: mms, ims) + | Some m -> + ( mms + , if Module.has_intf m then + Module.name m :: ims + else + ims + )) + in + let module_list ms = + List.map ms ~f:Module.Name.to_string + |> String.concat ~sep:"\n" + in + if missing_modules <> [] then begin + Errors.fail lib.buildable.loc + "Library %a cannot implement %a because the following \ + modules lack an implementation:\n%s" + Lib_name.Local.pp lib.name + Lib_name.pp implements + (module_list missing_modules) + end; + if impl_modules_with_intf <> [] then begin + Errors.fail lib.buildable.loc + "The following modules cannot have .mli files as they implement \ + virtual modules:\n%s" + (module_list impl_modules_with_intf) + end; + { Implementation. + impl = lib + ; vlib + ; vlib_modules + } + end +end diff --git a/src/virtual_rules.mli b/src/virtual_rules.mli new file mode 100644 index 00000000..e0d8e60b --- /dev/null +++ b/src/virtual_rules.mli @@ -0,0 +1,18 @@ +open Stdune + +module Implementation : sig + type t +end + +module Gen (S : sig val sctx : Super_context.t end) : sig + val setup_copy_rules_for_impl + : dir:Path.t + -> Implementation.t + -> unit + + val impl + : lib:Dune_file.Library.t + -> scope:Scope.t + -> modules:Module.Name_map.t + -> Implementation.t option +end