From 7353ff62ae395b8fb54d14409528f2da90cdd490 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 31 Jul 2025 14:14:32 +0200 Subject: [PATCH 01/26] feat(oxcaml): instantiate parameterized libraries Signed-off-by: ArthurW --- bin/describe/describe_external_lib_deps.ml | 2 +- src/dune_lang/lib_dep.ml | 46 ++ src/dune_lang/lib_dep.mli | 6 + src/dune_rules/compilation_context.ml | 20 +- src/dune_rules/compilation_context.mli | 4 +- src/dune_rules/dir_contents.ml | 2 +- src/dune_rules/dune_package.ml | 2 + src/dune_rules/exe_rules.ml | 2 + src/dune_rules/findlib.ml | 2 + src/dune_rules/gen_rules.ml | 13 +- src/dune_rules/lib.ml | 492 ++++++++++-- src/dune_rules/lib.mli | 37 + src/dune_rules/lib_flags.ml | 20 +- src/dune_rules/lib_info.ml | 38 + src/dune_rules/lib_info.mli | 3 + src/dune_rules/lib_rules.ml | 2 + src/dune_rules/ml_sources.ml | 17 +- src/dune_rules/module_compilation.ml | 28 +- src/dune_rules/modules.ml | 20 +- src/dune_rules/modules.mli | 2 + src/dune_rules/obj_dir.ml | 9 +- src/dune_rules/obj_dir.mli | 8 + src/dune_rules/parameterized_name.ml | 62 ++ src/dune_rules/parameterized_name.mli | 10 + src/dune_rules/parameterized_rules.ml | 341 ++++++++ src/dune_rules/parameterized_rules.mli | 8 + src/dune_rules/stanzas/library.ml | 4 + .../oxcaml/instantiate-exponential.t | 94 +++ .../oxcaml/instantiate-parameterized.t | 760 ++++++++++++++++++ 29 files changed, 1941 insertions(+), 113 deletions(-) create mode 100644 src/dune_rules/parameterized_name.ml create mode 100644 src/dune_rules/parameterized_name.mli create mode 100644 src/dune_rules/parameterized_rules.ml create mode 100644 src/dune_rules/parameterized_rules.mli create mode 100644 test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t create mode 100644 test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t diff --git a/bin/describe/describe_external_lib_deps.ml b/bin/describe/describe_external_lib_deps.ml index 69ae01fb8a0..4949a3795b9 100644 --- a/bin/describe/describe_external_lib_deps.ml +++ b/bin/describe/describe_external_lib_deps.ml @@ -97,7 +97,7 @@ let resolve_lib_deps db lib_deps = let open Memo.O in Memo.parallel_map lib_deps ~f:(fun (lib : Lib_dep.t) -> match lib with - | Direct (_, name) | Re_export (_, name) -> + | Direct (_, name) | Re_export (_, name) | Instantiate { lib = name; _ } -> let+ v = resolve_lib db name Kind.Required in [ v ] | Select select -> diff --git a/src/dune_lang/lib_dep.ml b/src/dune_lang/lib_dep.ml index 54e57cc59cc..8489097cb1a 100644 --- a/src/dune_lang/lib_dep.ml +++ b/src/dune_lang/lib_dep.ml @@ -98,6 +98,12 @@ type t = | Direct of (Loc.t * Lib_name.t) | Re_export of (Loc.t * Lib_name.t) | Select of Select.t + | Instantiate of + { loc : Loc.t + ; lib : Lib_name.t + ; arguments : (Loc.t * Lib_name.t) list + ; new_name : Module_name.t option + } let equal = Poly.equal @@ -107,6 +113,13 @@ let to_dyn = | Direct (_, name) -> Lib_name.to_dyn name | Re_export (_, name) -> variant "re_export" [ Lib_name.to_dyn name ] | Select s -> variant "select" [ Select.to_dyn s ] + | Instantiate { lib; arguments; new_name; loc = _ } -> + variant + "instantiate" + [ Lib_name.to_dyn lib + ; list (fun (_, arg) -> Lib_name.to_dyn arg) arguments + ; option Module_name.to_dyn new_name + ] ;; let direct x = Direct x @@ -126,6 +139,19 @@ let decode ~allow_re_export = , let+ select = Select.decode in Select select ) ] + <|> enter + ((* TODO art-w: oxcaml extension is not recognized by installed + libraries, which are missing a `(using oxcaml 0.1)` + let+ () = Syntax.since Oxcaml.syntax (0, 1) *) + let+ () = Syntax.since Stanza.syntax (3, 20) + and+ loc, lib = located Lib_name.decode + and+ arguments, new_name = + until_keyword + ":as" + ~before:(located Lib_name.decode) + ~after:Module_name.decode + in + Instantiate { loc; lib; arguments; new_name }) <|> let+ loc, name = located Lib_name.decode in Direct (loc, name)) in @@ -144,11 +170,22 @@ let encode = Code_error.raise "Lib_dep.encode: cannot encode select" [ "select", Select.to_dyn select ] + | Instantiate { lib; arguments; new_name; loc = _ } -> + let as_name = + match new_name with + | None -> [] + | Some new_name -> [ string ":as"; Module_name.encode new_name ] + in + list + sexp + ((Lib_name.encode lib :: List.map arguments ~f:(fun (_, arg) -> Lib_name.encode arg)) + @ as_name) ;; module L = struct type kind = | Required + | Required_multiple | Optional | Forbidden @@ -186,12 +223,21 @@ module L = struct [ Pp.textf "library %S is present both as a forbidden and required dependency" (Lib_name.to_string name) + ] + | Required_multiple, Required_multiple -> acc + | Required_multiple, _ | _, Required_multiple -> + User_error.raise + ~loc + [ Pp.textf + "parameterized library %S is present in multiple forms" + (Lib_name.to_string name) ]) in ignore (List.fold_left t ~init:Lib_name.Map.empty ~f:(fun acc x -> match x with | Re_export (_, s) | Direct (_, s) -> add Required s acc + | Instantiate { lib = s; _ } -> add Required_multiple s acc | Select { choices; _ } -> List.fold_left choices ~init:acc ~f:(fun acc (c : Select.Choice.t) -> let acc = Lib_name.Set.fold c.required ~init:acc ~f:(add Optional) in diff --git a/src/dune_lang/lib_dep.mli b/src/dune_lang/lib_dep.mli index e04fa2c064d..a08b7dd2fa9 100644 --- a/src/dune_lang/lib_dep.mli +++ b/src/dune_lang/lib_dep.mli @@ -22,6 +22,12 @@ type t = | Direct of (Loc.t * Lib_name.t) | Re_export of (Loc.t * Lib_name.t) | Select of Select.t + | Instantiate of + { loc : Loc.t + ; lib : Lib_name.t + ; arguments : (Loc.t * Lib_name.t) list + ; new_name : Module_name.t option + } val equal : t -> t -> bool val to_dyn : t -> Dyn.t diff --git a/src/dune_rules/compilation_context.ml b/src/dune_rules/compilation_context.ml index 0c82358745b..4dcc751ae61 100644 --- a/src/dune_rules/compilation_context.ml +++ b/src/dune_rules/compilation_context.ml @@ -89,6 +89,7 @@ type t = ; requires_link : Lib.t list Resolve.t Memo.Lazy.t ; implements : Virtual_rules.t ; parameters : Module_name.t list Resolve.Memo.t + ; instances : Lib.Parameterized.instance list Resolve.Memo.t ; includes : Includes.t ; preprocessing : Pp_spec.t ; opaque : bool @@ -162,6 +163,7 @@ let create ?modes ?bin_annot ?loc + ?instances () = let project = Scope.project scope in @@ -187,6 +189,11 @@ let create | None -> Resolve.Memo.return [] | Some parameters -> parameters_main_modules parameters in + let instances = + match instances with + | None -> Resolve.Memo.return [] + | Some instances -> instances + in let sandbox = Sandbox_config.no_special_requirements in let modes = let default = @@ -236,6 +243,7 @@ let create ; bin_annot ; loc ; ocaml + ; instances } ;; @@ -244,7 +252,7 @@ let alias_and_root_module_flags = fun base -> Ocaml_flags.append_common base extra ;; -let for_alias_module t alias_module = +let for_alias_module ~has_instances t alias_module = let keep_flags = Modules.With_vlib.is_stdlib_alias (modules t) alias_module in let flags = if keep_flags @@ -256,6 +264,15 @@ let for_alias_module t alias_module = let profile = Super_context.context t.super_context |> Context.profile in Ocaml_flags.default ~dune_version ~profile) in + let flags = + if has_instances + then + (* If the alias file instantiates parameterized libraries, + the [misplace-attribute] warning is currently raised on + [@jane.non_erasable.instances] *) + Ocaml_flags.append_common flags [ "-w"; "-53" ] + else flags + in let sandbox = (* If the compiler reads the cmi for module alias even with [-w -49 -no-alias-deps], we must sandbox the build of the alias module since the @@ -342,3 +359,4 @@ let for_plugin_executable t ~embed_in_plugin_libraries = let without_bin_annot t = { t with bin_annot = false } let set_obj_dir t obj_dir = { t with obj_dir } let set_modes t ~modes = { t with modes } +let instances t = t.instances diff --git a/src/dune_rules/compilation_context.mli b/src/dune_rules/compilation_context.mli index 77d451d420f..cf611742245 100644 --- a/src/dune_rules/compilation_context.mli +++ b/src/dune_rules/compilation_context.mli @@ -38,11 +38,12 @@ val create -> ?modes:Mode_conf.Set.Details.t Lib_mode.Map.t -> ?bin_annot:bool -> ?loc:Loc.t + -> ?instances:Lib.Parameterized.instance list Resolve.Memo.t -> unit -> t Memo.t (** Return a compilation context suitable for compiling the alias module. *) -val for_alias_module : t -> Module.t -> t +val for_alias_module : has_instances:bool -> t -> Module.t -> t val super_context : t -> Super_context.t val context : t -> Context.t @@ -90,3 +91,4 @@ val dep_graphs : t -> Dep_graph.t Ml_kind.Dict.t val loc : t -> Loc.t option val set_obj_dir : t -> Path.Build.t Obj_dir.t -> t val set_modes : t -> modes:Lib_mode.Map.Set.t -> t +val instances : t -> Lib.Parameterized.instance list Resolve.Memo.t diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 6552c1f838f..0283be29589 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -129,7 +129,7 @@ end = struct dependencies *) List.filter_map libraries ~f:(fun dep -> match (dep : Lib_dep.t) with - | Re_export _ | Direct _ -> None + | Re_export _ | Direct _ | Instantiate _ -> None | Select s -> Some s.result_fn) ;; diff --git a/src/dune_rules/dune_package.ml b/src/dune_rules/dune_package.ml index 1704afeb558..6055b88983a 100644 --- a/src/dune_rules/dune_package.ml +++ b/src/dune_rules/dune_package.ml @@ -254,6 +254,7 @@ module Lib = struct | Public (_, _) -> Lib_info.Status.Installed in let version = None in + let local_main_module_name = main_module_name in let main_module_name = Lib_info.Inherited.This main_module_name in let foreign_objects = Lib_info.Source.External foreign_objects in let public_headers = Lib_info.File_deps.External public_headers in @@ -281,6 +282,7 @@ module Lib = struct ~version ~synopsis ~main_module_name + ~local_main_module_name ~sub_systems ~requires ~parameters diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml index b9c48809009..cd11975623a 100644 --- a/src/dune_rules/exe_rules.ml +++ b/src/dune_rules/exe_rules.ml @@ -184,6 +184,7 @@ let executables_rules let* cctx = let requires_compile = Lib.Compile.direct_requires compile_info in let requires_link = Lib.Compile.requires_link compile_info in + let instances = Lib.Compile.instances compile_info in let js_of_ocaml = Js_of_ocaml.Mode.Pair.mapi js_of_ocaml ~f:(fun mode x -> Option.some_if @@ -205,6 +206,7 @@ let executables_rules ~opaque:Inherit_from_settings ~melange_package_name:None ~package:exes.package + ~instances in let lib_config = ocaml.lib_config in let* requires_compile = Compilation_context.requires_compile cctx in diff --git a/src/dune_rules/findlib.ml b/src/dune_rules/findlib.ml index 6a24d276fdf..f0636fffd17 100644 --- a/src/dune_rules/findlib.ml +++ b/src/dune_rules/findlib.ml @@ -143,6 +143,7 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc let implements = None in let parameters = [] in let orig_src_dir = None in + let local_main_module_name = None in let main_module_name : Lib_info.Main_module_name.t = This None in let enabled = Memo.return Lib_info.Enabled_status.Normal in let requires = @@ -252,6 +253,7 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc ~version ~synopsis ~main_module_name + ~local_main_module_name ~sub_systems ~requires ~parameters diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index 4bd2a32a970..cc86e7c114c 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -517,7 +517,14 @@ let gen_rules_regular_directory (sctx : Super_context.t Memo.t) ~src_dir ~compon (* XXX sync this list with the pattern matches above. It's quite ugly we need this, we should rewrite this code to avoid this. *) Filename.Set.of_list - [ ".js"; "_doc"; "_doc_new"; ".ppx"; ".dune"; ".topmod" ] + [ ".js" + ; "_doc" + ; "_doc_new" + ; ".ppx" + ; ".dune" + ; ".topmod" + ; ".parameterized" + ] in Filename.Set.union automatic toplevel in @@ -605,6 +612,10 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t = ~dir (Subdir_set.of_set (Filename.Set.of_list [ "cc_vendor" ])) (fun () -> Configurator_rules.gen_rules ctx) + | ".parameterized" :: rest -> + let* sctx = sctx + and* scope = Scope.DB.find_by_dir dir in + Parameterized_rules.gen_rules ~sctx ~scope ~dir rest | _ -> gen_rules_regular_directory sctx ~src_dir ~components ~dir ;; diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index a1cd3726a67..1115d035287 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -269,7 +269,26 @@ module Error = struct make_resolve ~loc [ Pp.textf "Parameter %S is missing." name ] - ~hints:[ Pp.textf "Add (parameters %s)" name ] + ~hints: + [ Pp.textf + "Pass an argument implementing %s to the dependency, or add (parameters %s)" + name + name + ] + ;; + + let missing_implements ~loc p = + let name = Lib_name.to_string (Lib_info.name p) in + make_resolve + ~loc + [ Pp.textf "Library %S does not implement a library parameter." name ] + ;; + + let too_many_arguments ?loc p = + make_resolve + ?loc + [ Pp.textf "Unexpected argument %S" (Lib_name.to_string (Lib_info.name p)) ] + ~hints:[ Pp.text "Remove the extra argument" ] ;; end @@ -349,6 +368,12 @@ end = struct module Top_closure = Top_closure.Make (Set) (Resolve.Memo) end +type instance = + { new_name : Module_name.t + ; lib_name : Module_name.t + ; args : (Module_name.t * Module_name.t) list + } + module T = struct type t = { info : Lib_info.external_ @@ -362,6 +387,8 @@ module T = struct ; pps : t list Resolve.t ; resolved_selects : Resolved_select.t list Resolve.t ; parameters : t list Resolve.t + ; arguments : argument option list + ; instances : instance list Resolve.t ; implements : t Resolve.t option ; project : Dune_project.t option ; (* these fields cannot be forced until the library is instantiated *) @@ -369,7 +396,22 @@ module T = struct ; sub_systems : Sub_system0.Instance.t Memo.Lazy.t Sub_system_name.Map.t } - let compare (x : t) (y : t) = Id.compare x.unique_id y.unique_id + and argument = + { arg : t + ; param_name : Module_name.t + ; arg_name : Module_name.t + ; loc : Loc.t + } + + let rec compare (x : t) (y : t) = + match Id.compare x.unique_id y.unique_id with + | (Lt | Gt) as cmp -> cmp + | Eq -> compare_arguments x y + + and compare_arguments a b = + List.compare a.arguments b.arguments ~compare:(Option.compare compare_argument) + + and compare_argument x y = compare x.arg y.arg let to_dyn t = Dyn.record @@ -472,29 +514,235 @@ let is_local t = not (Context_name.equal (Context_name.of_string name) Private_context.t.name)) ;; -let main_module_name t = +let resolve_main_module_name t = + let open Resolve.O in match Lib_info.main_module_name t.info with - | This mmn -> Resolve.Memo.return mmn + | This mmn -> Resolve.return mmn | From _ -> - let+ vlib = Memo.return (Option.value_exn t.implements) in - (match Lib_info.main_module_name vlib.info with - | This x -> x - | From _ -> assert false) + let+ impl = Option.value_exn t.implements in + (match Lib_info.kind impl.info with + | Parameter -> Lib_info.local_main_module_name t.info + | Virtual -> + (match Lib_info.main_module_name impl.info with + | This x -> x + | From _ -> assert false) + | Dune_file _ -> Code_error.raise "expected implementation" [ "lib", to_dyn t ]) ;; +let main_module_name t = Memo.return (resolve_main_module_name t) + module Parameterized = struct - let validate_required_parameters ~loc ~parameters lib = + type nonrec argument = argument = + { arg : t + ; param_name : Module_name.t + ; arg_name : Module_name.t + ; loc : Loc.t + } + + type nonrec instance = instance = + { new_name : Module_name.t + ; lib_name : Module_name.t + ; args : (Module_name.t * Module_name.t) list + } + + type status = + | Not_parameterized + | Partial + | Complete + + let status t = + if List.for_all t.arguments ~f:Option.is_none + then Not_parameterized + else ( + let rec check_instantiate lib = + List.for_all lib.arguments ~f:(function + | None -> false + | Some arg -> check_instantiate arg.arg) + in + if check_instantiate t then Complete else Partial) + ;; + + let arguments t = + List.map t.arguments ~f:(function + | None -> Code_error.raise "expected complete application" [ "lib", to_dyn t ] + | Some { arg; _ } -> arg) + ;; + + let parameterized_arguments t = + let open Resolve.O in + let+ parameters = t.parameters in + List.combine parameters t.arguments + ;; + + let apply_arguments ~ignore_extra t new_arguments = + let open Resolve.O in + let rec go acc existing' given' = + match existing', given' with + | (param_intf, Some arg) :: existing, _ -> + go ((param_intf, Some arg) :: acc) existing given' + | [], [] -> Resolve.return (List.rev acc) + | [], _ when ignore_extra -> Resolve.return (List.rev acc) + | [], (_, extra) :: _ -> Error.too_many_arguments ~loc:extra.loc extra.arg.info + | ((param_intf, None) as keep) :: existing, (param_intf', arg) :: given -> + (match compare param_intf param_intf' with + | Eq -> go ((param_intf, Some arg) :: acc) existing given + | Lt -> go (keep :: acc) existing given' + | Gt when ignore_extra -> go acc existing' given + | Gt -> Error.too_many_arguments ~loc:arg.loc arg.arg.info) + | ((_, None) as keep) :: existing, [] -> go (keep :: acc) existing [] + in + let* t_arguments = parameterized_arguments t in + let+ arguments = go [] t_arguments new_arguments in + let arguments = List.map ~f:snd arguments in + { t with arguments } + ;; + + let make_instance lib ~new_name = let open Resolve.O in let* lib = lib in - let* required_parameters = lib.parameters in + let* lib_name = resolve_main_module_name lib in + let lib_name = Option.value_exn lib_name in + let new_name = + match new_name with + | None -> lib_name + | Some m -> m + in + let+ arguments = + let* lib_arguments = parameterized_arguments lib in + Resolve.List.filter_map lib_arguments ~f:(function + | _, None -> Resolve.return None + | param, Some { arg; _ } -> + let+ param_name = resolve_main_module_name param + and+ arg_name = resolve_main_module_name arg in + (match param_name, arg_name with + | Some param_name, Some arg_name -> Some (param_name, arg_name) + | _ -> + Code_error.raise + "expected argument to have a main module name" + [ "arg", to_dyn arg ])) + in + { new_name; lib_name; args = arguments } + ;; + + let make_argument (loc, arg) = + let open Resolve.O in + let* arg = arg in + let* param = + match arg.implements with + | Some param -> param + | None -> Error.missing_implements ~loc arg.info + in + let+ param_name = resolve_main_module_name param + and+ arg_name = resolve_main_module_name arg in + ( param + , { arg + ; param_name = Option.value_exn param_name + ; arg_name = Option.value_exn arg_name + ; loc + } ) + ;; + + let make_arguments arguments = + let open Resolve.O in + let+ arguments = Resolve.List.map arguments ~f:make_argument in + List.sort arguments ~compare:(fun (param, _) (param', _) -> compare param param') + ;; + + let instantiate ~loc named_lib args ~parent_parameters = + let open Resolve.O in + let* lib = named_lib + and* args = make_arguments args in + let* lib = apply_arguments ~ignore_extra:false lib args in let+ () = - Resolve.List.iter required_parameters ~f:(function - | param when not (List.exists parameters ~f:(equal param)) -> + let* all_args = parameterized_arguments lib in + Resolve.List.iter all_args ~f:(function + | param, None when not (List.exists parent_parameters ~f:(equal param)) -> Error.missing_parameter ~loc param.info | _ -> Resolve.return ()) in lib ;; + + let complement_arguments ~parent dep = + let open Resolve.O in + let* parent_arguments = parameterized_arguments parent in + let parent_arguments = + List.filter_map parent_arguments ~f:(fun (param, opt_arg) -> + Option.map opt_arg ~f:(fun arg -> param, arg)) + in + let* arguments = + Resolve.List.map dep.arguments ~f:(fun opt_arg -> + match opt_arg with + | None -> Resolve.return None + | Some argument -> + let+ arg = apply_arguments ~ignore_extra:true argument.arg parent_arguments in + Some { argument with arg }) + in + apply_arguments ~ignore_extra:true { dep with arguments } parent_arguments + ;; + + let remove_arguments lib = { lib with parameters = Resolve.return []; arguments = [] } + + let requires lib = + let open Resolve.O in + let* (deps : lib list) = lib.requires in + let* deps = + Resolve.List.map deps ~f:(fun dep -> complement_arguments ~parent:lib dep) + in + let lib_arguments = + List.filter_map lib.arguments ~f:(function + | None -> None + | Some arg -> Some arg.arg) + in + let deps = List.rev_append lib_arguments deps in + let deps = + match lib_arguments with + | [] -> deps + | _ -> remove_arguments lib :: deps + in + Resolve.return deps + ;; + + let parameterized_name t = + let rec parameterized_name t = + let args = arguments t |> List.map ~f:parameterized_name in + { Parameterized_name.name = Lib_name.to_string (name t); args } + in + Parameterized_name.to_string (parameterized_name t) + ;; + + let info ~build_dir ~ext_lib t = + match status t with + | Not_parameterized | Partial -> None + | Complete -> + let parameterized_dir = Path.Build.relative build_dir ".parameterized" in + let subdir = parameterized_name t in + let dir = Path.Build.relative parameterized_dir subdir in + Some (Lib_info.for_instance ~dir ~ext_lib t.info) + ;; + + let rec for_instance ~build_dir ~ext_lib t = + match info ~build_dir ~ext_lib t with + | None -> { t with arguments = [] } + | Some info -> + let arguments = + List.map t.arguments ~f:(function + | None -> None + | Some arg -> Some { arg with arg = for_instance ~build_dir ~ext_lib arg.arg }) + in + { t with info = Lib_info.of_local info; arguments } + ;; + + let rec applied_modules t = arguments t |> Resolve.List.map ~f:applied_name + + and applied_name t = + let open Resolve.O in + let+ name = resolve_main_module_name t + and+ args = applied_modules t in + match name with + | Some name -> { Parameterized_name.name = Module_name.to_string name; args } + | None -> Code_error.raise "library missing main module name" [ "lib", to_dyn t ] + ;; end let wrapped t = @@ -628,7 +876,7 @@ module Dep_stack : sig type t = Default_for of Id.t end - val push : t -> implements_via:Implements_via.t option -> Id.t -> t Resolve.Memo.t + val push : t -> implements_via:Implements_via.t option -> lib -> t Resolve.Memo.t end = struct module Implements_via = struct type t = Default_for of Id.t @@ -642,10 +890,10 @@ end = struct type t = { stack : Id.t list ; implements_via : Implements_via.t Id.Map.t - ; seen : Id.Set.t + ; seen : Set.t } - let empty = { stack = []; seen = Id.Set.empty; implements_via = Id.Map.empty } + let empty = { stack = []; seen = Set.empty; implements_via = Id.Map.empty } let to_required_by t = List.map t.stack ~f:(fun ({ Id.path; name; _ } as id) -> @@ -657,8 +905,9 @@ end = struct { Dep_path.Entry.lib = { path; name }; implements_via }) ;; - let dependency_cycle t (last : Id.t) = - assert (Id.Set.mem t.seen last); + let dependency_cycle t (last : lib) = + assert (Set.mem t.seen last); + let last = last.unique_id in let rec build_loop acc stack = match stack with | [] -> assert false @@ -670,17 +919,17 @@ end = struct Error.dependency_cycle loop ;; - let push (t : t) ~implements_via (x : Id.t) = - if Id.Set.mem t.seen x + let push (t : t) ~implements_via (x : lib) = + if Set.mem t.seen x then dependency_cycle t x else ( let implements_via = match implements_via with | None -> t.implements_via - | Some via -> Id.Map.add_exn t.implements_via x via + | Some via -> Id.Map.add_exn t.implements_via x.unique_id via in Resolve.Memo.return - { stack = x :: t.stack; seen = Id.Set.add t.seen x; implements_via }) + { stack = x.unique_id :: t.stack; seen = Set.add t.seen x; implements_via }) ;; end @@ -768,24 +1017,32 @@ end = struct | (lib, stack) :: libs -> (match lib.implements, Lib_info.kind lib.info with | None, Dune_file _ -> loop acc libs - | None, (Parameter | Virtual) -> loop (Map.set acc lib (No_impl stack)) libs + | None, Parameter -> loop acc libs + | None, Virtual -> loop (Map.set acc lib (No_impl stack)) libs | Some _, (Parameter | Virtual) -> assert false (* can't be virtual and implement *) - | Some vlib, Dune_file _ -> - let* vlib = Memo.return vlib in - (match Map.find acc vlib with - | None -> - (* we've already traversed the virtual library because it must - have occurred earlier in the closure *) - assert false - | Some (No_impl _) -> loop (Map.set acc vlib (Impl (lib, stack))) libs - | Some (Impl (lib', stack')) -> - let req_by' = Dep_stack.to_required_by stack' in - let req_by = Dep_stack.to_required_by stack in - Error.double_implementation - (lib'.info, req_by') - (lib.info, req_by) - ~vlib:vlib.info)) + | Some impl, Dune_file _ -> + let* impl = Memo.return impl in + (match Lib_info.kind impl.info with + | Parameter -> loop acc libs + | Virtual -> + (match Map.find acc impl with + | None -> + (* we've already traversed the virtual library because it must + have occurred earlier in the closure *) + assert false + | Some (No_impl _) -> loop (Map.set acc impl (Impl (lib, stack))) libs + | Some (Impl (lib', stack')) -> + let req_by' = Dep_stack.to_required_by stack' in + let req_by = Dep_stack.to_required_by stack in + Error.double_implementation + (lib'.info, req_by') + (lib.info, req_by) + ~vlib:impl.info) + | Dune_file _ -> + Code_error.raise + "implements expected Virtual or Parameter" + [ "lib", to_dyn lib ])) in loop Map.empty closure ;; @@ -810,7 +1067,7 @@ end = struct module M = State.Make (struct - type t = lib list * Id.Set.t + type t = lib list * Set.t end) (Resolve.Memo) @@ -823,16 +1080,16 @@ end = struct let rec loop t = let t = Option.value ~default:t (Map.find impls t) in let* res, visited = R.get in - if Id.Set.mem visited t.unique_id + if Set.mem visited t then R.return () else - let* () = R.set (res, Id.Set.add visited t.unique_id) in - let* deps = R.lift (Memo.return t.requires) in + let* () = R.set (res, Set.add visited t) in + let* deps = R.lift (Resolve.Memo.lift (Parameterized.requires t)) in let* () = many deps in R.modify (fun (res, visited) -> t :: res, visited) and many deps = R.List.iter deps ~f:loop in let open Resolve.Memo.O in - let+ (res, _visited), () = R.run (many ts) ([], Id.Set.empty) in + let+ (res, _visited), () = R.run (many ts) ([], Set.empty) in List.rev res ;; @@ -895,6 +1152,7 @@ module rec Resolve_names : sig ; pps : lib list Resolve.t ; selects : Resolved_select.t list ; re_exports : lib list Resolve.t + ; instances : Parameterized.instance list Resolve.t } end @@ -951,7 +1209,7 @@ end = struct let* lib = Resolve.Memo.lift lib in (match Lib_info.kind lib.info with | Parameter -> Resolve.Memo.return (Some (loc, name, lib)) - | _ -> Error.expected_parameter ~loc ~name)) + | Virtual | Dune_file _ -> Error.expected_parameter ~loc ~name)) in let parameters = List.stable_sort parameters ~compare:(fun (_, _, a) (_, _, b) -> compare a b) @@ -1025,28 +1283,34 @@ end = struct Memo.map res ~f:Option.some in let* requires = - let requires = + let open Resolve.Memo.O in + let* requires = + Memo.return + @@ let open Resolve.O in - let* resolved = resolved in - resolved.requires + let* resolved = resolved + and* resolved_params = parameters in + let+ requires = resolved.requires in + requires @ resolved_params in match implements with - | None -> Memo.return requires - | Some vlib -> - let open Resolve.Memo.O in + | None -> Resolve.Memo.return requires + | Some impl -> let* () = - let* vlib = Memo.return vlib in - let* requires_for_closure_check = - Memo.return - (let open Resolve.O in - let+ requires = requires in - List.filter requires ~f:(fun lib -> not (equal lib vlib))) - in - check_forbidden - requires_for_closure_check - ~forbidden_libraries:(Map.singleton vlib Loc.none) + let* impl = Memo.return impl in + match Lib_info.kind impl.info with + | Parameter -> Resolve.Memo.return () + | Virtual -> + let requires_for_closure_check = + List.filter requires ~f:(fun lib -> not (Ordering.is_eq (compare lib impl))) + in + check_forbidden + requires_for_closure_check + ~forbidden_libraries:(Map.singleton impl Loc.none) + | Dune_file _ -> + Code_error.raise "expected Virtual or Parameter" [ "implements", to_dyn impl ] in - Memo.return requires + Resolve.Memo.return requires in let resolve_impl impl_name = let open Resolve.Memo.O in @@ -1128,6 +1392,7 @@ end = struct let resolved_selects = resolved >>| fun r -> r.selects in let pps = resolved >>= fun r -> r.pps in let re_exports = resolved >>= fun r -> r.re_exports in + let instances = resolved >>= fun r -> r.instances in { info ; name ; unique_id @@ -1136,8 +1401,10 @@ end = struct ; pps ; resolved_selects ; re_exports + ; instances ; implements ; parameters + ; arguments = List.map ~f:(fun _ -> None) (Lib_info.parameters info) ; default_implementation ; project ; sub_systems = @@ -1373,6 +1640,7 @@ end = struct { resolved : t list Resolve.t ; selects : Resolved_select.t list ; re_exports : t list Resolve.t + ; instances : Parameterized.instance list Resolve.t } type t = @@ -1380,6 +1648,7 @@ end = struct ; pps : lib list Resolve.t ; selects : Resolved_select.t list ; re_exports : lib list Resolve.t + ; instances : Parameterized.instance list Resolve.t } module Builder : sig @@ -1389,6 +1658,7 @@ end = struct val add_resolved : t -> lib Resolve.t -> t val add_re_exports : t -> lib Resolve.t -> t val add_select : t -> lib list Resolve.t -> Resolved_select.t -> t + val add_instance : t -> Parameterized.instance Resolve.t -> t val value : t -> deps end = struct open Resolve.O @@ -1396,7 +1666,11 @@ end = struct type nonrec t = deps let empty = - { resolved = Resolve.return []; selects = []; re_exports = Resolve.return [] } + { resolved = Resolve.return [] + ; selects = [] + ; re_exports = Resolve.return [] + ; instances = Resolve.return [] + } ;; let add_resolved_list t resolved = @@ -1428,7 +1702,16 @@ end = struct add_resolved { t with re_exports } lib ;; - let value { resolved; selects; re_exports } = + let add_instance (t : t) instance = + let instances = + let+ instance = instance + and+ instances = t.instances in + instance :: instances + in + { t with instances } + ;; + + let value { resolved; selects; re_exports; instances } = let resolved = let+ resolved = resolved in List.rev resolved @@ -1437,7 +1720,7 @@ end = struct let+ re_exports = re_exports in List.rev re_exports in - { resolved; selects; re_exports } + { resolved; selects; re_exports; instances } ;; end end @@ -1469,29 +1752,46 @@ end = struct res, { Resolved_select.src_fn; dst_fn = result_fn } ;; - let resolve_complex_deps db deps ~private_deps ~parameters : Resolved.deps Memo.t = + let resolve_complex_deps db deps ~private_deps ~parameters = let open Memo.O in - let resolve_parameterized_dep (loc, lib) = + let resolve_parameterized_dep (loc, lib) ~arguments = resolve_dep db (loc, lib) ~private_deps >>| function | None -> None - | Some dep -> Some (Parameterized.validate_required_parameters ~loc ~parameters dep) + | Some dep -> + Some (Parameterized.instantiate ~loc dep arguments ~parent_parameters:parameters) in Memo.List.fold_left ~init:Resolved.Builder.empty deps ~f:(fun acc (dep : Lib_dep.t) -> match dep with | Re_export lib -> - resolve_parameterized_dep lib + resolve_parameterized_dep lib ~arguments:[] >>| (function | None -> acc | Some lib -> Resolved.Builder.add_re_exports acc lib) | Direct lib -> - resolve_parameterized_dep lib + resolve_parameterized_dep lib ~arguments:[] >>| (function | None -> acc | Some lib -> Resolved.Builder.add_resolved acc lib) | Select select -> let+ resolved, select = resolve_select db ~private_deps select in - Resolved.Builder.add_select acc resolved select) + Resolved.Builder.add_select acc resolved select + | Instantiate { loc; new_name; lib; arguments; _ } -> + let* arguments = + Memo.List.filter_map arguments ~f:(fun (loc, dep) -> + resolve_parameterized_dep (loc, dep) ~arguments:[] + >>| Option.map ~f:(fun dep -> loc, dep)) + in + let acc = + List.fold_left arguments ~init:acc ~f:(fun acc (_loc, dep) -> + Resolved.Builder.add_resolved acc dep) + in + resolve_parameterized_dep (loc, lib) ~arguments + >>| (function + | None -> acc + | Some lib -> + let acc = Resolved.Builder.add_resolved acc lib in + Resolved.Builder.add_instance acc (Parameterized.make_instance lib ~new_name))) |> Memo.map ~f:Resolved.Builder.value ;; @@ -1550,7 +1850,7 @@ end = struct let add_pp_runtime_deps db - { Resolved.resolved; selects; re_exports } + { Resolved.resolved; selects; re_exports; instances } ~private_deps ~parameters ~pps @@ -1565,7 +1865,7 @@ end = struct let* runtime_deps = runtime_deps in re_exports_closure (List.concat [ resolved; runtime_deps; parameters ]) and+ pps = pps in - { Resolved.requires; pps; selects; re_exports } + { Resolved.requires; pps; selects; re_exports; instances } ;; let resolve_deps_and_add_runtime_deps @@ -1702,13 +2002,13 @@ end = struct in (* If the library has an implementation according to variants or default impl. *) - if not (Lib_info.virtual_ lib.info) - then R.return () - else + match Lib_info.kind lib.info with + | Dune_file _ -> R.return () + | Parameter | Virtual -> let* impl = R.lift (impl_for lib) in - match impl with - | None -> R.return () - | Some impl -> visit ~stack:(lib.info :: stack) (Some lib) impl) + (match impl with + | None -> R.return () + | Some impl -> visit ~stack:(lib.info :: stack) (Some lib) impl)) in (* For each virtual library we know which vlibs will be implemented when enabling its default implementation. *) @@ -1758,7 +2058,7 @@ end = struct Vlib.associate (List.rev state.result) kind ;; - let rec visit (t : t) ~stack (implements_via, lib) = + let rec visit (t : t) ~stack (implements_via, (lib : lib)) = let open R.O in let* state = R.get in if Set.mem state.visited lib @@ -1787,7 +2087,7 @@ end = struct find_internal db lib.name >>= function | Status.Found lib' -> - if lib = lib' + if Ordering.is_eq (Id.compare lib.unique_id lib'.unique_id) then Resolve.Memo.return () else ( let req_by = Dep_stack.to_required_by stack in @@ -1799,14 +2099,19 @@ end = struct ; "lib.name", Lib_name.to_dyn lib.name ])) in - let* new_stack = R.lift (Dep_stack.push stack ~implements_via lib.unique_id) in - let* deps = R.lift (Memo.return lib.requires) in + let* new_stack = R.lift (Dep_stack.push stack ~implements_via lib) in + let* (deps : lib list) = + R.lift (Resolve.Memo.lift (Parameterized.requires lib)) + in let* unimplemented' = R.lift (Vlib.Unimplemented.add state.unimplemented lib) in let* () = R.modify (fun state -> { state with unimplemented = unimplemented' }) in let* () = R.List.iter deps ~f:(fun l -> visit t (None, l) ~stack:new_stack) in - R.modify (fun state -> { state with result = (lib, stack) :: state.result })) + (match Parameterized.status lib with + | Partial -> R.return () + | Not_parameterized | Complete -> + R.modify (fun state -> { state with result = (lib, stack) :: state.result }))) ;; end @@ -1903,6 +2208,7 @@ module Compile = struct type nonrec t = { direct_requires : t list Resolve.Memo.t + ; instances : Parameterized.instance list Resolve.Memo.t ; requires_link : t list Resolve.t Memo.Lazy.t ; pps : t list Resolve.Memo.t ; resolved_selects : Resolved_select.t list Resolve.Memo.t @@ -1931,6 +2237,7 @@ module Compile = struct ~forbidden_libraries:Map.empty) in { direct_requires = requires + ; instances = Memo.return t.instances ; requires_link ; resolved_selects = Memo.return t.resolved_selects ; pps = Memo.return t.pps @@ -1939,6 +2246,7 @@ module Compile = struct ;; let direct_requires t = t.direct_requires + let instances t = t.instances let requires_link t = t.requires_link let resolved_selects t = t.resolved_selects let pps t = t.pps @@ -2201,7 +2509,13 @@ module DB = struct let+ resolved = Memo.Lazy.force resolved in resolved.selects in + let instances = + let open Memo.O in + let+ resolved = Memo.Lazy.force resolved in + resolved.instances + in { Compile.direct_requires + ; instances ; requires_link ; pps ; resolved_selects = resolved_selects |> Memo.map ~f:Resolve.return @@ -2296,7 +2610,19 @@ let to_dune_lib List.map requires ~f:(fun lib -> if List.exists re_exports ~f:(fun r -> r = lib) then Lib_dep.Re_export (loc, mangled_name lib) - else Direct (loc, mangled_name lib)) + else ( + match lib.arguments with + | [] -> Direct (loc, mangled_name lib) + | args -> + Instantiate + { loc + ; lib = mangled_name lib + ; arguments = + List.filter_map args ~f:(function + | None -> None + | Some arg -> Some (arg.loc, mangled_name arg.arg)) + ; new_name = None + })) in let name = mangled_name lib in let remove_public_dep_prefix paths = diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index 9698c567e76..1dbd99d4417 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -14,6 +14,41 @@ val name : t -> Lib_name.t val implements : t -> t Resolve.Memo.t option val parameters : t -> t list Resolve.Memo.t +module Parameterized : sig + type status = + | Not_parameterized + | Partial + | Complete + + val status : t -> status + + type argument = private + { arg : t + ; param_name : Module_name.t + ; arg_name : Module_name.t + ; loc : Loc.t + } + + val arguments : t -> t list + val applied_modules : t -> Parameterized_name.t list Resolve.t + val applied_name : t -> Parameterized_name.t Resolve.t + val requires : t -> t list Resolve.t + val for_instance : build_dir:Path.Build.t -> ext_lib:string -> t -> t + + val instantiate + : loc:Loc.t + -> t Resolve.t + -> (Loc.t * t Resolve.t) list + -> parent_parameters:t list + -> t Resolve.t + + type instance = private + { new_name : Module_name.t + ; lib_name : Module_name.t + ; args : (Module_name.t * Module_name.t) list + } +end + (** [is_local t] returns [true] whenever [t] is defined in the local workspace *) val is_local : t -> bool @@ -64,6 +99,8 @@ module Compile : sig (** Dependencies listed by the user + runtime dependencies from ppx *) val direct_requires : t -> lib list Resolve.Memo.t + val instances : t -> Parameterized.instance list Resolve.Memo.t + module Resolved_select : sig type t = { src_fn : Filename.t Resolve.t diff --git a/src/dune_rules/lib_flags.ml b/src/dune_rules/lib_flags.ml index a70b4387d45..c4c3e6a9419 100644 --- a/src/dune_rules/lib_flags.ml +++ b/src/dune_rules/lib_flags.ml @@ -315,10 +315,14 @@ module Lib_and_module = struct let link_flags sctx ts ~(lib_config : Lib_config.t) ~mode = let open Action_builder.O in + let build_dir = Context.build_dir (Super_context.context sctx) in Command.Args.Dyn (let+ l = Action_builder.List.map ts ~f:(function | Lib t -> + let t = + Lib.Parameterized.for_instance ~build_dir ~ext_lib:lib_config.ext_lib t + in let+ { Link_params.hidden_deps; include_dirs; deps } = Action_builder.of_memo (Link_params.get sctx t mode lib_config) in @@ -336,16 +340,16 @@ module Lib_and_module = struct ~kind:(Ocaml (Mode.cm_kind (Link_mode.mode mode)))) :: (match mode with - | Byte | Byte_for_jsoo | Byte_with_stubs_statically_linked_in -> [] | Native -> [ Command.Args.Hidden_deps - ([ Obj_dir.Module.o_file_exn - obj_dir - m - ~ext_obj:lib_config.ext_obj - ] - |> Dep.Set.of_files) - ])) + (Dep.Set.of_files + [ Obj_dir.Module.o_file_exn + obj_dir + m + ~ext_obj:lib_config.ext_obj + ]) + ] + | Byte | Byte_for_jsoo | Byte_with_stubs_statically_linked_in -> [])) |> Action_builder.return) in Command.Args.S l) diff --git a/src/dune_rules/lib_info.ml b/src/dune_rules/lib_info.ml index d8dcd660289..419b547a980 100644 --- a/src/dune_rules/lib_info.ml +++ b/src/dune_rules/lib_info.ml @@ -330,6 +330,7 @@ type 'path t = ; default_implementation : (Loc.t * Lib_name.t) option ; wrapped : Wrapped.t Inherited.t option ; main_module_name : Main_module_name.t + ; local_main_module_name : Module_name.t option ; modes : Lib_mode.Map.Set.t ; modules : Modules.With_vlib.t option Source.t ; special_builtin_support : (Loc.t * Special_builtin_support.t) option @@ -377,6 +378,7 @@ let special_builtin_support t = t.special_builtin_support let jsoo_runtime t = t.jsoo_runtime let wasmoo_runtime t = t.wasmoo_runtime let main_module_name t = t.main_module_name +let local_main_module_name t = t.local_main_module_name let orig_src_dir t = t.orig_src_dir let best_src_dir t = Option.value ~default:t.src_dir t.orig_src_dir let set_version t version = { t with version } @@ -404,6 +406,7 @@ let create ~version ~synopsis ~main_module_name + ~local_main_module_name ~sub_systems ~requires ~parameters @@ -446,6 +449,7 @@ let create ; requires ; parameters ; main_module_name + ; local_main_module_name ; foreign_objects ; public_headers ; plugins @@ -543,6 +547,7 @@ let to_dyn ; requires ; parameters ; main_module_name + ; local_main_module_name ; foreign_objects ; public_headers ; plugins @@ -607,6 +612,7 @@ let to_dyn ; "default_implementation", option (snd Lib_name.to_dyn) default_implementation ; "wrapped", option (Inherited.to_dyn Wrapped.to_dyn) wrapped ; "main_module_name", Main_module_name.to_dyn main_module_name + ; "local_main_module_name", Dyn.option Module_name.to_dyn local_main_module_name ; "modes", Lib_mode.Map.Set.to_dyn modes ; "modules", Source.to_dyn (Dyn.option Modules.With_vlib.to_dyn) modules ; ( "special_builtin_support" @@ -685,3 +691,35 @@ let for_dune_package | `Dir -> dir) else p) ;; + +let for_instance ~dir ~ext_lib t = + let obj_dir = + Obj_dir.make_lib + ~dir + ~has_private_modules:false + ~private_lib:false + (Lib_name.Local.of_string "instance") + in + let archives = + Mode.Dict.mapi t.archives ~f:(fun m _ -> + [ Path.Build.relative dir ("archive" ^ Mode.compiled_lib_ext m) ]) + in + let native_archives = Files [ Path.Build.relative dir ("archive" ^ ext_lib) ] in + { t with + obj_dir + ; archives + ; native_archives + ; modules = External None + ; src_dir = dir + ; orig_src_dir = None + ; plugins = Mode.Dict.make ~byte:[] ~native:[] + ; foreign_objects = Local + ; public_headers = File_deps.External [] + ; foreign_archives = Mode.Map.empty + ; foreign_dll_files = [] + ; jsoo_runtime = [] + ; wasmoo_runtime = [] + ; path_kind = Local + ; melange_runtime_deps = File_deps.External [] + } +;; diff --git a/src/dune_rules/lib_info.mli b/src/dune_rules/lib_info.mli index 896e37b61f1..fd537b62555 100644 --- a/src/dune_rules/lib_info.mli +++ b/src/dune_rules/lib_info.mli @@ -143,6 +143,7 @@ val obj_dir : 'path t -> 'path Obj_dir.t val virtual_ : _ t -> bool val entry_modules : _ t -> (Module_name.t list, User_message.t) result Source.t val main_module_name : _ t -> Main_module_name.t +val local_main_module_name : _ t -> Module_name.t option val wrapped : _ t -> Wrapped.t Inherited.t option val special_builtin_support : _ t -> (Loc.t * Special_builtin_support.t) option val modes : _ t -> Lib_mode.Map.Set.t @@ -203,6 +204,7 @@ val create -> version:Package_version.t option -> synopsis:string option -> main_module_name:Main_module_name.t + -> local_main_module_name:Module_name.t option -> sub_systems:Sub_system_info.t Sub_system_name.Map.t -> requires:Lib_dep.t list -> parameters:(Loc.t * Lib_name.t) list @@ -235,3 +237,4 @@ val create val package : _ t -> Package.Name.t option val to_dyn : 'path Dyn.builder -> 'path t Dyn.builder +val for_instance : dir:Path.Build.t -> ext_lib:string -> Path.t t -> Path.Build.t t diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index a46ca8f203b..3c9f9a343bf 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -512,6 +512,7 @@ let cctx let modules = Virtual_rules.impl_modules implements modules in let requires_compile = Lib.Compile.direct_requires compile_info in let requires_link = Lib.Compile.requires_link compile_info in + let instances = Lib.Compile.instances compile_info in let* modes = let+ ocaml = let ctx = Super_context.context sctx in @@ -551,6 +552,7 @@ let cctx ~package ~melange_package_name ~modes + ~instances ;; let library_rules diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index 389f156a1a2..7281c365aa6 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -335,6 +335,12 @@ let virtual_modules ~lookup_vlib ~libs vlib = } ;; +let has_instances (lib : Buildable.t) = + List.exists lib.libraries ~f:(function + | Lib_dep.Instantiate _ -> true + | Direct _ | Re_export _ | Select _ -> false) +;; + let make_lib_modules ~expander ~dir @@ -438,11 +444,13 @@ let make_lib_modules in let implements = Option.is_some lib.implements in let _loc, lib_name = lib.name in + let has_instances = has_instances lib.buildable in Resolve.Memo.return ( sources , Modules.lib ~stdlib:lib.stdlib ~implements + ~has_instances ~lib_name ~obj_dir:dir ~modules @@ -488,10 +496,11 @@ let modules_of_stanzas = ~version:exes.dune_version modules_settings in + let has_instances = has_instances exes.buildable in let modules = let obj_dir = Obj_dir.obj_dir obj_dir in if Dune_project.wrapped_executables project - then Modules.make_wrapped ~obj_dir ~modules `Exe + then Modules.make_wrapped ~obj_dir ~modules ~has_instances `Exe else Modules.exe_unwrapped modules ~obj_dir in `Executables { Per_stanza.stanza = exes; sources; modules; obj_dir; dir } @@ -548,7 +557,11 @@ let modules_of_stanzas = mel.modules in let modules = - Modules.make_wrapped ~obj_dir:(Obj_dir.obj_dir obj_dir) ~modules `Melange + Modules.make_wrapped + ~obj_dir:(Obj_dir.obj_dir obj_dir) + ~modules + ~has_instances:false + `Melange in `Melange_emit { Per_stanza.stanza = mel; sources; modules; dir; obj_dir } | _ -> Memo.return `Skip)) diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index 84c3237c144..cdf51f6de16 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -465,9 +465,10 @@ module Alias_module = struct type t = { aliases : alias list ; shadowed : Module_name.t list + ; instances : Lib.Parameterized.instance list } - let to_ml { aliases; shadowed } = + let to_ml { aliases; shadowed; instances } = let b = Buffer.create 16 in Buffer.add_string b "(* generated by dune *)\n"; List.iter aliases ~f:(fun { canonical_path; local_name; obj_name } -> @@ -485,10 +486,22 @@ module Alias_module = struct b "\nmodule %s = struct end\n[@@deprecated \"this module is shadowed\"]\n" (Module_name.to_string shadowed)); + List.iter instances ~f:(fun (instance : Lib.Parameterized.instance) -> + Printf.bprintf + b + "\nmodule %s = %s%s [@jane.non_erasable.instances]" + (Module_name.to_string instance.new_name) + (Module_name.to_string instance.lib_name) + (String.concat ~sep:"" + @@ List.map instance.args ~f:(fun (param_name, arg_name) -> + Printf.sprintf + "(%s)(%s)" + (Module_name.to_string param_name) + (Module_name.to_string arg_name)))); Buffer.contents b ;; - let of_modules project modules group = + let of_modules project modules group instances = let aliases = Modules.Group.for_alias group |> List.map ~f:(fun (local_name, m) -> @@ -505,18 +518,19 @@ module Alias_module = struct | Alias _ -> [] | _ -> [ Module.name (Modules.Group.alias group) ]) in - { aliases; shadowed } + { aliases; shadowed; instances } ;; end let build_alias_module cctx group = + let* instances = Resolve.Memo.read_memo (Compilation_context.instances cctx) in + let has_instances = instances <> [] in let alias_file () = let project = Compilation_context.scope cctx |> Scope.project in let modules = Compilation_context.modules cctx in - Alias_module.of_modules project modules group |> Alias_module.to_ml + Alias_module.of_modules project modules group instances |> Alias_module.to_ml in let alias_module = Modules.Group.alias group in - let cctx = Compilation_context.for_alias_module cctx alias_module in let sctx = Compilation_context.super_context cctx in let file = Option.value_exn (Module.file alias_module ~ml_kind:Impl) in let dir = Compilation_context.dir cctx in @@ -528,7 +542,7 @@ let build_alias_module cctx group = (Action_builder.delayed alias_file |> Action_builder.write_file_dyn (Path.as_in_build_dir_exn file)) in - let cctx = Compilation_context.for_alias_module cctx alias_module in + let cctx = Compilation_context.for_alias_module ~has_instances cctx alias_module in build_module cctx alias_module ;; @@ -590,7 +604,7 @@ let build_all cctx = then (* XXX it would probably be simpler if the flags were just for this module in the definition of the stanza *) - Compilation_context.for_alias_module cctx m + Compilation_context.for_alias_module ~has_instances:false cctx m else cctx in build_module cctx m)) diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index dc07f1a1ce4..7a3b440ebbb 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -792,7 +792,17 @@ let to_dyn t = | Stdlib s -> variant "Stdlib" [ Stdlib.to_dyn s ] ;; -let lib ~obj_dir ~main_module_name ~wrapped ~stdlib ~lib_name ~implements ~modules = +let lib + ~obj_dir + ~main_module_name + ~wrapped + ~stdlib + ~lib_name + ~implements + ~has_instances + ~modules + = + (* TODO art-w: if [has_instances] is true, then we always need an alias file *) let make_wrapped main_module_name = Wrapped (Wrapped.make ~obj_dir ~lib_name ~implements ~modules ~main_module_name ~wrapped) @@ -810,7 +820,7 @@ let lib ~obj_dir ~main_module_name ~wrapped ~stdlib ~lib_name ~implements ~modul let mangle = Mangle.Unwrapped in Unwrapped (Unwrapped.of_trie modules ~mangle ~obj_dir) | (Yes_with_transition _ | Simple true), Some main_module_name, Some m -> - if Module.name m = main_module_name && not implements + if Module.name m = main_module_name && (not implements) && not has_instances then Singleton m else make_wrapped main_module_name | (Yes_with_transition _ | Simple true), Some main_module_name, None -> @@ -837,15 +847,15 @@ let exe_unwrapped modules ~obj_dir = with_obj_map modules ;; -let make_wrapped ~obj_dir ~modules kind = +let make_wrapped ~obj_dir ~modules ~has_instances kind = let mangle : Mangle.t = match kind with | `Exe -> Exe | `Melange -> Melange in match Module_trie.as_singleton modules with - | Some m -> make_singleton m mangle - | None -> + | Some m when not has_instances -> make_singleton m mangle + | _ -> let modules = Wrapped (Wrapped.make_exe_or_melange ~obj_dir ~modules mangle) in with_obj_map modules ;; diff --git a/src/dune_rules/modules.mli b/src/dune_rules/modules.mli index 40ff6968dea..4926477b285 100644 --- a/src/dune_rules/modules.mli +++ b/src/dune_rules/modules.mli @@ -13,6 +13,7 @@ val lib -> stdlib:Ocaml_stdlib.t option -> lib_name:Lib_name.Local.t -> implements:bool + -> has_instances:bool -> modules:Module.t Module_trie.t -> t @@ -32,6 +33,7 @@ val exe_unwrapped : Module.t Module_trie.t -> obj_dir:Path.Build.t -> t val make_wrapped : obj_dir:Path.Build.t -> modules:Module.t Module_trie.t + -> has_instances:bool -> [ `Exe | `Melange ] -> t diff --git a/src/dune_rules/obj_dir.ml b/src/dune_rules/obj_dir.ml index 903cd23b6eb..1bd474d03bc 100644 --- a/src/dune_rules/obj_dir.ml +++ b/src/dune_rules/obj_dir.ml @@ -504,13 +504,16 @@ module Module = struct | External _ -> dir ;; - let obj_file (type path) (t : path t) m ~kind ~ext : path = - let visibility = Module.visibility m in - let obj_name = Module_name.Unique.artifact_filename (Module.obj_name m) ~ext in + let obj_file_of_name (type path) (t : path t) m ~kind ~ext ~visibility : path = + let obj_name = Module_name.Unique.artifact_filename m ~ext in let dir = cm_dir t kind visibility in relative t dir obj_name ;; + let obj_file (type path) (t : path t) m ~kind ~ext : path = + obj_file_of_name t (Module.obj_name m) ~kind ~ext ~visibility:(Module.visibility m) + ;; + let has_impl_if_needed m ~(kind : Lib_mode.Cm_kind.t) = match kind with | Ocaml (Cmo | Cmx) | Melange Cmj -> Module.has m ~ml_kind:Impl diff --git a/src/dune_rules/obj_dir.mli b/src/dune_rules/obj_dir.mli index 0d523fa8f16..e68a7e02321 100644 --- a/src/dune_rules/obj_dir.mli +++ b/src/dune_rules/obj_dir.mli @@ -104,6 +104,14 @@ module Module : sig -> cm_kind:Lib_mode.Cm_kind.t -> 'path option + val obj_file_of_name + : 'path t + -> Module_name.Unique.t + -> kind:Lib_mode.Cm_kind.t + -> ext:string + -> visibility:Visibility.t + -> 'path + val obj_file : 'path t -> Module.t -> kind:Lib_mode.Cm_kind.t -> ext:string -> 'path (** Same as [cm_file] but raises if [cm_kind] is [Cmo] or [Cmx] and the module diff --git a/src/dune_rules/parameterized_name.ml b/src/dune_rules/parameterized_name.ml new file mode 100644 index 00000000000..ed18aa7090d --- /dev/null +++ b/src/dune_rules/parameterized_name.ml @@ -0,0 +1,62 @@ +open Import + +type t = + { name : string + ; args : t list + } + +let of_string ~sep str = + let rec count_empty total = function + | "" :: rest -> count_empty (total + 1) rest + | rest -> total, rest + in + let parts = String.split_on_char ~sep str in + let rec apply depth { name; args } arg = + let args = + match depth, args with + | 0, _ -> arg :: args + | _, hd :: args -> apply (depth - 1) hd arg :: args + | _ -> assert false + in + { name; args } + in + let t, rest = + match parts with + | [] -> assert false + | name :: rest -> { name; args = [] }, rest + in + let rec go t rest = + let depth, rest = count_empty 0 rest in + match rest with + | [] -> + assert (Int.equal depth 0); + t + | name :: rest -> + let t = apply depth t { name; args = [] } in + go t rest + in + go t rest +;; + +let to_string ~sep t = + let sep = String.make 1 sep in + let buf = Buffer.create 16 in + let rec go apply_sep { name; args } = + Buffer.add_string buf name; + let apply_sep' = sep ^ apply_sep in + List.iter args ~f:(fun arg -> + Buffer.add_string buf apply_sep; + go apply_sep' arg) + in + go sep t; + Buffer.contents buf +;; + +let to_module_name t = + let applied_name = to_string ~sep:'-' t in + let module_name = Module_name.of_string_allow_invalid (Loc.none, applied_name) in + Module_name.Unique.of_name_assuming_needs_no_mangling module_name +;; + +let of_string str = of_string ~sep:'!' str +let to_string t = to_string ~sep:'!' t diff --git a/src/dune_rules/parameterized_name.mli b/src/dune_rules/parameterized_name.mli new file mode 100644 index 00000000000..ac94262a41b --- /dev/null +++ b/src/dune_rules/parameterized_name.mli @@ -0,0 +1,10 @@ +open Import + +type t = + { name : string + ; args : t list + } + +val of_string : string -> t +val to_string : t -> string +val to_module_name : t -> Module_name.Unique.t diff --git a/src/dune_rules/parameterized_rules.ml b/src/dune_rules/parameterized_rules.ml new file mode 100644 index 00000000000..34dc4445a28 --- /dev/null +++ b/src/dune_rules/parameterized_rules.ml @@ -0,0 +1,341 @@ +open Import +open Memo.O + +let obj_file ~obj_dir ~kind ?ext unique_name = + let ext = + match ext with + | None -> Lib_mode.Cm_kind.ext kind + | Some ext -> ext + in + Obj_dir.Module.obj_file_of_name obj_dir unique_name ~kind ~ext ~visibility:Public +;; + +let get_cm ~kind lib = + let open Resolve.O in + let+ name = Lib.Parameterized.applied_name lib in + let unique_name = Parameterized_name.to_module_name name in + let obj_dir = Lib_info.obj_dir (Lib.info lib) in + obj_file ~obj_dir ~kind unique_name +;; + +type t = + { module_ : Path.t + ; args : Path.t list Resolve.t + ; requires : Lib.t list Resolve.t + ; target : Path.Build.t + ; o_target : Path.Build.t option + ; hidden_targets : Path.Build.t list + ; hidden_deps : Dep.Set.t Action_builder.t + } + +let build_instance ~sctx ~obj_dir ~mode instance = + let { module_; args; requires; target; o_target = _; hidden_targets; hidden_deps } = + instance + in + let ctx = Super_context.context sctx in + let* ocaml = Context.ocaml ctx in + let include_flags = + Action_builder.of_memo + @@ + let+ requires = Resolve.read_memo requires in + Lib_flags.L.include_flags + ~direct_libs:requires + ~hidden_libs:[] + (Ocaml mode) + ocaml.lib_config + in + let dir = + let cm_kind = Lib_mode.Cm_kind.Ocaml (Mode.cm_kind mode) in + Obj_dir.cm_dir obj_dir cm_kind Public + in + Ocaml_toolchain.compiler ocaml mode + |> Memo.Result.iter ~f:(fun compiler -> + [ Command.Args.Dyn include_flags + ; S + (List.concat_map + ~f:(fun dir -> [ Command.Args.A "-H"; Path (Path.build dir) ]) + (Obj_dir.all_obj_dirs ~mode:(Lib_mode.Ocaml mode) obj_dir)) + ; A "-w" + ; A "-55" + (* CR art-w: ignore [inlining-impossible] warning, it's unclear + why it happens *) + ; A "-instantiate" + ; Dep module_ + ; Dyn + (Action_builder.of_memo + @@ + let+ args = Resolve.read_memo args in + Command.Args.Deps args) + ; Dyn + (let open Action_builder.O in + let+ hidden_deps = hidden_deps in + Command.Args.Hidden_deps hidden_deps) + ; A "-o" + ; Target target + ; Hidden_targets hidden_targets + ] + |> Command.run + ~sandbox:Sandbox_config.needs_sandboxing + (Ok compiler) + ~dir:(Path.build dir) + |> Super_context.add_rule ~dir sctx) +;; + +let build_archive ~sctx ~mode ~obj_dir ~lib ~top_sorted_modules ~modules = + let lib_info = Lib_info.as_local_exn (Lib.info lib) in + let target = + match Mode.Dict.get (Lib_info.archives lib_info) mode with + | [ target ] -> target + | [] | _ :: _ :: _ -> + Code_error.raise + "expected single target" + [ "info", Lib_info.to_dyn Path.Build.to_dyn lib_info ] + in + let hidden_targets = + match mode, Lib_info.native_archives lib_info with + | Native, Files lst -> lst + | Byte, _ -> [] + | Native, Needs_module_info _ -> + Code_error.raise + "expected native archive files" + [ "info", Lib_info.to_dyn Path.Build.to_dyn lib_info ] + in + let dir = + let cm_kind = Lib_mode.Cm_kind.Ocaml (mode |> Mode.cm_kind) in + Obj_dir.cm_dir obj_dir cm_kind Public + in + let* ocaml = Context.ocaml (Super_context.context sctx) in + Ocaml_toolchain.compiler ocaml mode + |> Memo.Result.iter ~f:(fun compiler -> + [ Command.Args.S + (List.concat_map + ~f:(fun dir -> [ Command.Args.A "-H"; Path (Path.build dir) ]) + (Obj_dir.all_obj_dirs ~mode:(Lib_mode.Ocaml mode) obj_dir)) + ; A "-a" + ; Dyn + (let open Action_builder.O in + let+ top_sorted_modules = top_sorted_modules in + let deps = + List.filter_map top_sorted_modules ~f:(fun m -> + let name = Module.name m in + match Module_name.Map.find modules name with + | None -> None + | Some inst -> Some (Path.build inst.target)) + in + Command.Args.Deps deps) + ; Dyn + (let open Action_builder.O in + let+ top_sorted_modules = top_sorted_modules in + let deps = + Dep.Set.of_list + @@ List.filter_map top_sorted_modules ~f:(fun m -> + let name = Module.name m in + match Module_name.Map.find modules name with + | Some { o_target = Some o_target; _ } -> + Some (Dep.file (Path.build o_target)) + | None | Some { o_target = None; _ } -> None) + in + Command.Args.Hidden_deps deps) + ; A "-o" + ; Target target + ; Hidden_targets hidden_targets + ] + |> Command.run + ~sandbox:Sandbox_config.needs_sandboxing + (Ok compiler) + ~dir:(Path.build dir) + |> Super_context.add_rule ~dir sctx) +;; + +let lib_hidden_deps ~kind lib requires = + Action_builder.of_memo + @@ + let* requires = Resolve.read_memo requires in + Memo.List.concat_map requires ~f:(fun dep -> + match Lib.compare lib dep with + | Eq -> Memo.return [] + | Lt | Gt -> + (match Lib.Parameterized.status dep with + | Complete -> + let+ cm = Resolve.read_memo (get_cm ~kind dep) in + [ cm ] + | Partial -> + Code_error.raise + "unexpected partial application" + [ "lib", Lib.to_dyn lib; "dep", Lib.to_dyn dep ] + | Not_parameterized -> + let+ cmi = Resolve.read_memo (get_cm ~kind:(Ocaml Cmi) dep) in + [ cmi ])) + >>| Dep.Set.of_files +;; + +let apply_module_name module_ args = + let name = Module_name.Unique.to_string (Module.obj_name module_) in + Parameterized_name.to_module_name { name; args } +;; + +let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graphs ~mode ~requires ~lib modules + = + let kind = Lib_mode.Cm_kind.Ocaml (Mode.cm_kind mode) in + let ext = Lib_mode.Cm_kind.ext kind in + let cm_args = Lib.Parameterized.arguments lib |> Resolve.List.map ~f:(get_cm ~kind) in + let* { Lib_config.ext_obj; _ } = + let+ ocaml = Super_context.context sctx |> Context.ocaml in + ocaml.lib_config + in + let lib_hidden_deps = lib_hidden_deps ~kind lib requires in + let* args = + (* The main module names of applied arguments is required + because it's used in the instantiated filenames. + If we are instantiating a library, then the existence + of these module names has already been checked and the + resolve can't fail. *) + Resolve.read_memo @@ Lib.Parameterized.applied_modules lib + in + Memo.List.fold_left modules ~init:Module_name.Map.empty ~f:(fun acc module_ -> + let instance = + let module_cm = Obj_dir.Module.obj_file modules_obj_dir module_ ~kind ~ext in + let module_cmi = + Obj_dir.Module.cm_file_exn modules_obj_dir module_ ~kind:(Ocaml Cmi) + in + let unique_name = apply_module_name module_ args in + let target = obj_file ~obj_dir ~kind ~ext unique_name in + let o_target = + match mode with + | Native -> Some (obj_file ~obj_dir ~kind ~ext:ext_obj unique_name) + | Byte -> None + in + let hidden_targets = + match mode with + | Byte -> [] + | Native -> [ obj_file ~obj_dir ~kind ~ext:ext_obj unique_name ] + in + let hidden_deps = + let open Action_builder.O in + let+ lib_hidden_deps = lib_hidden_deps + and+ module_deps = Dep_graph.deps_of dep_graphs module_ in + let deps = + List.map module_deps ~f:(fun module_ -> + apply_module_name module_ args |> obj_file ~obj_dir ~kind |> Path.build) + in + Dep.Set.union lib_hidden_deps (Dep.Set.of_files (module_cmi :: deps)) + in + { module_ = module_cm + ; args = cm_args + ; requires + ; target + ; o_target + ; hidden_targets + ; hidden_deps + } + in + let+ () = build_instance ~sctx ~obj_dir ~mode instance in + Module_name.Map.add_exn acc (Module.name module_) instance) +;; + +let iter_modes_concurrently ~(f : Ocaml.Mode.t -> unit Memo.t) = + let t = Mode.Dict.make_both true in + let+ () = Memo.when_ t.byte (fun () -> f Byte) + and+ () = Memo.when_ t.native (fun () -> f Native) in + () +;; + +let instantiate ~sctx lib = + let ctx = Super_context.context sctx in + let build_dir = Context.build_dir ctx in + let* { Lib_config.ext_lib; _ } = + let+ ocaml = ctx |> Context.ocaml in + ocaml.lib_config + in + let lib_info = Lib.info lib in + let modules_obj_dir = Lib_info.obj_dir lib_info in + let* modules = + match Lib_info.modules lib_info with + | External (Some modules) -> Memo.return modules + | External None -> failwith "external None" + | Local -> + let local_lib = Lib.Local.of_lib_exn lib in + let+ modules = Dir_contents.modules_of_local_lib sctx local_lib in + Modules.With_vlib.modules modules + in + let* requires = + Lib.closure ~linking:true [ lib ] + |> Resolve.Memo.map + ~f:(List.map ~f:(Lib.Parameterized.for_instance ~build_dir ~ext_lib)) + in + let lib = Lib.Parameterized.for_instance ~build_dir ~ext_lib lib in + let obj_dir = Lib_info.obj_dir (Lib.info lib) |> Obj_dir.as_local_exn in + let* dep_graphs = + let+ dg = + (* TODO art-w: If the lib is local, then don't recompute. If the lib is + global, then compute only once not once-per-instantiation. *) + Dep_rules.rules + ~dir:(Obj_dir.dir obj_dir) + ~sandbox:Sandbox_config.no_special_requirements + ~obj_dir + ~sctx + ~impl:Virtual_rules.no_implements + ~modules + in + dg.impl + in + let impl_only = Modules.With_vlib.impl_only modules in + let top_sorted_modules = Dep_graph.top_closed_implementations dep_graphs impl_only in + iter_modes_concurrently ~f:(fun mode -> + let* modules = + build_modules + ~sctx + ~obj_dir + ~modules_obj_dir + ~dep_graphs + ~mode + ~requires + ~lib + impl_only + in + build_archive ~sctx ~mode ~obj_dir ~lib ~top_sorted_modules ~modules) +;; + +let has_rules fn = + Memo.return + (Build_config.Gen_rules.make + ~directory_targets:Path.Build.Map.empty + (Rules.collect_unit fn)) +;; + +let resolve_instantiation scope str = + let db = Scope.libs scope in + let rec go { Parameterized_name.name; args } = + let name = Lib_name.of_string name in + let+ lib = Lib.DB.find db name + and+ args = Memo.List.map ~f:go args in + match lib with + | None -> Code_error.raise "library not found" [] + | Some lib -> + let args = List.map args ~f:(fun arg -> Loc.none, arg) in + Lib.Parameterized.instantiate + ~loc:Loc.none + (Resolve.return lib) + args + ~parent_parameters:[] + in + go (Parameterized_name.of_string str) |> Resolve.Memo.read_memo +;; + +let gen_rules ~sctx ~dir ~scope rest = + match rest with + | [] -> + Memo.return + (Build_config.Gen_rules.make + ~build_dir_only_sub_dirs: + (Build_config.Gen_rules.Build_only_sub_dirs.singleton ~dir Subdir_set.all) + (Memo.return Rules.empty)) + | [ folder ] -> + has_rules + @@ fun () -> + let* lib = resolve_instantiation scope folder in + instantiate ~sctx lib + | _ -> + Memo.return + (Build_config.Gen_rules.redirect_to_parent Build_config.Gen_rules.Rules.empty) +;; diff --git a/src/dune_rules/parameterized_rules.mli b/src/dune_rules/parameterized_rules.mli new file mode 100644 index 00000000000..4d9cc111cb0 --- /dev/null +++ b/src/dune_rules/parameterized_rules.mli @@ -0,0 +1,8 @@ +open Import + +val gen_rules + : sctx:Super_context.t + -> dir:Path.Build.t + -> scope:Scope.t + -> string list + -> Build_config.Gen_rules.result Memo.t diff --git a/src/dune_rules/stanzas/library.ml b/src/dune_rules/stanzas/library.ml index ffa33627892..1616835cabf 100644 --- a/src/dune_rules/stanzas/library.ml +++ b/src/dune_rules/stanzas/library.ml @@ -430,6 +430,8 @@ let obj_dir ~dir t = (snd t.name) ;; +let local_main_module_name t = Some (Module_name.of_local_lib_name t.name) + let main_module_name t : Lib_info.Main_module_name.t = match t.implements, t.wrapped with | Some x, From _ -> From x @@ -530,6 +532,7 @@ let to_lib_info in archives_for_mode ~f_ext:Mode.compiled_lib_ext, plugins) in + let local_main_module_name = local_main_module_name conf in let main_module_name = main_module_name conf in let name = best_name conf in let lib_id = @@ -607,6 +610,7 @@ let to_lib_info ~version ~synopsis ~main_module_name + ~local_main_module_name ~sub_systems ~requires ~parameters diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t new file mode 100644 index 00000000000..44a60dea58c --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t @@ -0,0 +1,94 @@ +The parameterized libraries can themselves implement a parameter, leading to +this exponential sequence of instantiations: + + $ cat >dune-project < (lang dune 3.20) + > (using oxcaml 0.1) + > (implicit_transitive_deps false) + > EOF + +A single parameter: + + $ mkdir x + $ echo 'val v : string' > x/x.mli + $ cat > x/dune < (library_parameter (name x)) + > EOF + +Various implementations of this parameter: + + $ echo 'let v = "X"' > x_impl.ml + $ echo 'let v = "F(" ^ X.v ^ ")"' > f.ml + $ echo 'let v = "G(" ^ F.v ^ ")"' > g.ml + $ echo 'let v = "H(" ^ G.v ^ ")"' > h.ml + $ echo 'let v = "I(" ^ H.v ^ ")"' > i.ml + $ echo 'let v = "J(" ^ I.v ^ ")"' > j.ml + +And a final binary: + + $ echo 'let () = print_endline J.v' > bin.ml + +Each implementation of `x` is itself parameterized by `x`, with a dependency on +the previous implementation with `(lib lib)` which causes this exponential +doubling: + + $ cat > dune < (library (name x_impl) (modules x_impl) (implements x)) + > (library (name f) (modules f) (parameters x) (implements x)) + > (library (name g) (modules g) (parameters x) (implements x) (libraries (f f))) + > (library (name h) (modules h) (parameters x) (implements x) (libraries (g g))) + > (library (name i) (modules i) (parameters x) (implements x) (libraries (h h))) + > (library (name j) (modules j) (parameters x) (implements x) (libraries (i i))) + > (executable (name bin) (modules bin) (libraries (j x_impl))) + > EOF + +The final result doubles for each layer: + + $ dune exec ./bin.exe + J(I(H(G(F(F(G(F(F(H(G(F(F(G(F(F(I(H(G(F(F(G(F(F(H(G(F(F(G(F(F(X))))))))))))))))))))))))))))))) + +Behind the scene, this test requires a correct encoding/decoding of +instantiated library names. For dune folders, the number of exclamation points +indicates the level of application nesting, i.e. `f!g!!x = f(g(x))` and `f!g!x += f(g)(x)`. + + $ ls _build/default/.parameterized + f!f!!g!!!h!!!!i!!!!!x_impl + f!f!!g!!!h!!!!x_impl + f!f!!g!!!i!!!!x_impl + f!f!!g!!!x_impl + f!f!!h!!!i!!!!x_impl + f!f!!h!!!x_impl + f!f!!i!!!x_impl + f!f!!x_impl + f!g!!h!!!i!!!!x_impl + f!g!!h!!!x_impl + f!g!!i!!!x_impl + f!g!!x_impl + f!h!!i!!!x_impl + f!h!!x_impl + f!i!!x_impl + f!x_impl + g!g!!h!!!i!!!!x_impl + g!g!!h!!!x_impl + g!g!!i!!!x_impl + g!g!!x_impl + g!h!!i!!!x_impl + g!h!!x_impl + g!i!!x_impl + g!x_impl + h!h!!i!!!x_impl + h!h!!x_impl + h!i!!x_impl + h!x_impl + i!i!!x_impl + i!x_impl + j!x_impl + +For modules instantiated by the compiler, a dash is used: + + $ ls _build/default/.parameterized/f!f!!g!!!h!!!!i!!!!!x_impl/.instance.objs/native + f-F--G---H----I-----X_impl.cmx + f-F--G---H----I-----X_impl.o + f__f__-F--G---H----I-----X_impl.cmx + f__f__-F--G---H----I-----X_impl.o diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t new file mode 100644 index 00000000000..6c22aef5135 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t @@ -0,0 +1,760 @@ +Testing the instantiation of parameterized libraries. This feature requires oxcaml: + + $ cat >> dune-project < (lang dune 3.20) + > (using oxcaml 0.1) + > (package (name project)) + > EOF + +We add two parameters: + + $ mkdir a + $ echo 'val a : string' > a/a.mli + $ cat >a/dune < (library_parameter (public_name project.a) (name a)) + > EOF + + $ mkdir b + $ echo 'val b : string' > b/b.mli + $ cat >b/dune < (library_parameter (public_name project.b) (name b)) + > EOF + +And two implementations, one with a singleton module and the other with more: + + $ mkdir a_impl + $ echo 'let a = "a"' > a_impl/a_impl.ml + $ cat >a_impl/dune < (library (public_name project.a_impl) (name a_impl) (implements a)) + > EOF + + $ mkdir b_impl + $ echo 'let b = "b"' > b_impl/b_dep.ml + $ echo 'let b = B_dep.b' > b_impl/b_impl.ml + $ cat >b_impl/dune < (library (public_name project.b_impl) (name b_impl) (implements b)) + > EOF + +And a parameterized library: + + $ mkdir lib_ab + $ echo 'let ab = A.a ^ B.b' > lib_ab/lib_ab.ml + $ cat >lib_ab/dune < (library (public_name project.lib_ab) (name lib_ab) (parameters a b)) + > EOF + + $ dune build + +Finally the binary can instantiate `lib_ab` by providing all its parameters: + + $ mkdir bin + $ echo 'let () = print_endline Lib_ab.ab' > bin/bin.ml + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries (lib_ab b_impl a_impl))) + > EOF + + $ dune exec project.bin + ab + +It's an error for the binary to partially instantiate `lib_ab`: + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries (lib_ab b_impl))) ; missing a_impl + > EOF + + $ dune exec project.bin + File "bin/dune", line 3, characters 14-20: + 3 | (libraries (lib_ab b_impl))) ; missing a_impl + ^^^^^^ + Error: Parameter "project.a" is missing. + -> required by _build/install/default/bin/project.bin + Hint: Pass an argument implementing project.a to the dependency, or add + (parameters project.a) + [1] + +It's an error to instantiate twice without renamming: (dune might be able to +catch this, but currently it doesn't check that libraries don't have +overlapping modules) + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > a_impl + > project.a_impl + > (lib_ab a_impl b_impl) + > (lib_ab a_impl b_impl))) + > EOF + + $ dune exec project.bin + File "bin/.bin.eobjs/dune__exe.ml-gen", line 7, characters 0-75: + 7 | module Lib_ab = Lib_ab(A)(A_impl)(B)(B_impl) [@jane.non_erasable.instances] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: Multiple definition of the module name Lib_ab. + Names must be unique in a given structure or signature. + [1] + +We add another way to implement the parameter `b` from the parameter `a`: + + $ mkdir a_of_b + $ echo 'let a = "a_of_b(" ^ B.b ^ ")"' > a_of_b/a_of_b.ml + $ cat >a_of_b/dune < (library + > (public_name project.a_of_b) + > (name a_of_b) + > (parameters b) + > (implements a)) + > EOF + +It's an error to use `a_of_b` as an argument for `lib_ab` in the executable +dependencies, because its parameter `b` is missing: + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > a_impl + > project.a_impl + > (lib_ab a_impl a_of_b))) + > EOF + + $ dune exec project.bin + File "bin/dune", line 6, characters 19-25: + 6 | (lib_ab a_impl a_of_b))) + ^^^^^^ + Error: Parameter "project.b" is missing. + -> required by _build/install/default/bin/project.bin + Hint: Pass an argument implementing project.b to the dependency, or add + (parameters project.b) + [1] + +However `lib_ab` can depend on `a_of_b`, such that the parameter `b` will be +implicitly passed to it: + + $ echo 'let ab = A.a ^ "," ^ A_of_b.a ^ "," ^ B.b' > lib_ab/lib_ab.ml + $ cat >lib_ab/dune < (library (public_name project.lib_ab) (name lib_ab) + > (parameters a b) + > (libraries a_of_b)) + > EOF + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > (lib_ab a_impl b_impl))) + > EOF + + $ dune exec project.bin + a,a_of_b(b),b + +We can also do a partial application of `lib_ab`: + + $ mkdir lib_apply + $ echo 'let ab = "lib_apply(" ^ Lib_ab.ab ^ ")"' > lib_apply/lib_apply.ml + $ cat >lib_apply/dune < (library + > (public_name project.lib_apply) + > (name lib_apply) + > (parameters b) + > (libraries (lib_ab a_impl))) + > EOF + +And use renaming with `:as` in the executable: + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > (lib_apply b_impl :as lib_ab))) + > EOF + + $ dune exec project.bin + lib_apply(a,a_of_b(b),b) + +It's an error to provide a non-required parameter: + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > (lib_apply a_impl b_impl :as lib_ab))) + > EOF + + $ dune exec project.bin + File "bin/dune", line 4, characters 15-21: + 4 | (lib_apply a_impl b_impl :as lib_ab))) + ^^^^^^ + Error: Unexpected argument "project.a_impl" + -> required by _build/install/default/bin/project.bin + Hint: Remove the extra argument + [1] + +Given another implementation of a parameter, we can instantiate the same +library multiple times by giving it different names: + + $ mkdir b_impl2 + $ echo 'let b = "b2"' > b_impl2/b_impl2.ml + $ cat >b_impl2/dune < (library (public_name project.b_impl2) (name b_impl2) (implements b)) + > EOF + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > (lib_apply b_impl :as applied_b) + > (lib_apply b_impl2 :as applied_b2))) + > EOF + + $ echo 'let () = print_endline Applied_b.ab' > bin/bin.ml + $ echo 'let () = print_endline Applied_b2.ab' >> bin/bin.ml + + $ dune exec project.bin + lib_apply(a,a_of_b(b),b) + lib_apply(a,a_of_b(b2),b2) + +We can also instantiate multiple times at the level of libraries: + + $ cat > lib_apply/lib_apply.ml < let ab = "lib_ab[a,?](" ^ Lib_a_.ab ^ ")" + > ^ " lib_ab[a,b](" ^ Lib_a_b.ab ^ ")" + > ^ " lib_ab[a_of_b[?],?](" ^ Lib_aofb_.ab ^ ")" + > ^ " lib_ab[a_of_b[?],b](" ^ Lib_aofb_b.ab ^ ")" + > EOF + $ cat >lib_apply/dune < (library (public_name project.lib_apply) (name lib_apply) + > (parameters b) + > (libraries + > (lib_ab a_impl :as lib_a_) ; partial application + > (lib_ab a_impl b_impl :as lib_a_b) ; full application + > (lib_ab a_of_b :as lib_aofb_) ; double partial application + > (lib_ab a_of_b b_impl :as lib_aofb_b) ; partial application on first argument + > )) + > EOF + + $ dune exec project.bin + lib_ab[a,?](a,a_of_b(b),b) lib_ab[a,b](a,a_of_b(b),b) lib_ab[a_of_b[?],?](a_of_b(b),a_of_b(b),b) lib_ab[a_of_b[?],b](a_of_b(b),a_of_b(b),b) + lib_ab[a,?](a,a_of_b(b2),b2) lib_ab[a,b](a,a_of_b(b),b) lib_ab[a_of_b[?],?](a_of_b(b2),a_of_b(b2),b2) lib_ab[a_of_b[?],b](a_of_b(b2),a_of_b(b),b) + +The same but using multiple files in the definition of `lib_apply`, with +arbitrary module dependencies: (as behind the scene, to instantiate the +library, each module must be instantiated separately and in dependency order) + + $ echo 'let ab = X.x ^ " " ^ Z.z' > lib_apply/lib_apply.ml + $ echo 'let x = "lib_ab[a,?](" ^ Lib_a_.ab ^ ") " ^ Y.y' > lib_apply/x.ml + $ echo 'let y = "lib_ab[a,b](" ^ Lib_a_b.ab ^ ") " ^ F.f' > lib_apply/y.ml + $ echo 'let f = "lib_ab[a_of_b[?],?](" ^ Lib_aofb_.ab ^ ")"' > lib_apply/f.ml + $ echo 'let z = "lib_ab[a_of_b[?],b](" ^ Lib_aofb_b.ab ^ ")"' > lib_apply/z.ml + $ dune exec project.bin + lib_ab[a,?](a,a_of_b(b),b) lib_ab[a,b](a,a_of_b(b),b) lib_ab[a_of_b[?],?](a_of_b(b),a_of_b(b),b) lib_ab[a_of_b[?],b](a_of_b(b),a_of_b(b),b) + lib_ab[a,?](a,a_of_b(b2),b2) lib_ab[a,b](a,a_of_b(b),b) lib_ab[a_of_b[?],?](a_of_b(b2),a_of_b(b2),b2) lib_ab[a_of_b[?],b](a_of_b(b2),a_of_b(b),b) + +The same compilation also works in bytecode: + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (modes byte) + > (libraries + > (lib_apply b_impl :as applied_b) + > (lib_apply b_impl2 :as applied_b2))) + > EOF + $ dune exec project.bin + lib_ab[a,?](a,a_of_b(b),b) lib_ab[a,b](a,a_of_b(b),b) lib_ab[a_of_b[?],?](a_of_b(b),a_of_b(b),b) lib_ab[a_of_b[?],b](a_of_b(b),a_of_b(b),b) + lib_ab[a,?](a,a_of_b(b2),b2) lib_ab[a,b](a,a_of_b(b),b) lib_ab[a_of_b[?],?](a_of_b(b2),a_of_b(b2),b2) lib_ab[a_of_b[?],b](a_of_b(b2),a_of_b(b),b) + +We check the installation: + + $ dune build @install + $ cat _build/install/default/lib/project/META + package "a" ( + directory = "a" + description = "" + requires = "" + archive(byte) = "" + archive(native) = "" + plugin(byte) = "" + plugin(native) = "" + ) + package "a_impl" ( + directory = "a_impl" + description = "" + requires = "project.a" + archive(byte) = "a_impl.cma" + archive(native) = "a_impl.cmxa" + plugin(byte) = "a_impl.cma" + plugin(native) = "a_impl.cmxs" + ) + package "a_of_b" ( + directory = "a_of_b" + description = "" + requires = "project.a project.b" + archive(byte) = "a_of_b.cma" + archive(native) = "a_of_b.cmxa" + plugin(byte) = "a_of_b.cma" + plugin(native) = "a_of_b.cmxs" + ) + package "b" ( + directory = "b" + description = "" + requires = "" + archive(byte) = "" + archive(native) = "" + plugin(byte) = "" + plugin(native) = "" + ) + package "b_impl" ( + directory = "b_impl" + description = "" + requires = "project.b" + archive(byte) = "b_impl.cma" + archive(native) = "b_impl.cmxa" + plugin(byte) = "b_impl.cma" + plugin(native) = "b_impl.cmxs" + ) + package "b_impl2" ( + directory = "b_impl2" + description = "" + requires = "project.b" + archive(byte) = "b_impl2.cma" + archive(native) = "b_impl2.cmxa" + plugin(byte) = "b_impl2.cma" + plugin(native) = "b_impl2.cmxs" + ) + package "lib_ab" ( + directory = "lib_ab" + description = "" + requires = "project.a project.a_of_b project.b" + archive(byte) = "lib_ab.cma" + archive(native) = "lib_ab.cmxa" + plugin(byte) = "lib_ab.cma" + plugin(native) = "lib_ab.cmxs" + ) + package "lib_apply" ( + directory = "lib_apply" + description = "" + requires = + "project.a_impl project.a_of_b project.b project.b_impl project.lib_ab" + archive(byte) = "lib_apply.cma" + archive(native) = "lib_apply.cmxa" + plugin(byte) = "lib_apply.cma" + plugin(native) = "lib_apply.cmxs" + ) + +The `dune-package` should list the different instantiations in the dependencies: + + $ cat _build/install/default/lib/project/dune-package | grep -v 'lang dune' + (name project) + (sections (lib .) (libexec .) (bin ../../bin)) + (files + (lib + (META + a/a.cmi + a/a.cmti + a/a.mli + a_impl/a_impl.a + a_impl/a_impl.cma + a_impl/a_impl.cmi + a_impl/a_impl.cmt + a_impl/a_impl.cmx + a_impl/a_impl.cmxa + a_impl/a_impl.ml + a_impl/a_impl__a_impl__.cmi + a_impl/a_impl__a_impl__.cmt + a_impl/a_impl__a_impl__.cmx + a_impl/a_impl__a_impl__.ml + a_of_b/a_of_b.a + a_of_b/a_of_b.cma + a_of_b/a_of_b.cmi + a_of_b/a_of_b.cmt + a_of_b/a_of_b.cmx + a_of_b/a_of_b.cmxa + a_of_b/a_of_b.ml + a_of_b/a_of_b__a_of_b__.cmi + a_of_b/a_of_b__a_of_b__.cmt + a_of_b/a_of_b__a_of_b__.cmx + a_of_b/a_of_b__a_of_b__.ml + b/b.cmi + b/b.cmti + b/b.mli + b_impl/b_dep.ml + b_impl/b_impl.a + b_impl/b_impl.cma + b_impl/b_impl.cmi + b_impl/b_impl.cmt + b_impl/b_impl.cmx + b_impl/b_impl.cmxa + b_impl/b_impl.ml + b_impl/b_impl__B_dep.cmi + b_impl/b_impl__B_dep.cmt + b_impl/b_impl__B_dep.cmx + b_impl/b_impl__b_impl__.cmi + b_impl/b_impl__b_impl__.cmt + b_impl/b_impl__b_impl__.cmx + b_impl/b_impl__b_impl__.ml + b_impl2/b_impl2.a + b_impl2/b_impl2.cma + b_impl2/b_impl2.cmi + b_impl2/b_impl2.cmt + b_impl2/b_impl2.cmx + b_impl2/b_impl2.cmxa + b_impl2/b_impl2.ml + b_impl2/b_impl2__b_impl2__.cmi + b_impl2/b_impl2__b_impl2__.cmt + b_impl2/b_impl2__b_impl2__.cmx + b_impl2/b_impl2__b_impl2__.ml + dune-package + lib_ab/lib_ab.a + lib_ab/lib_ab.cma + lib_ab/lib_ab.cmi + lib_ab/lib_ab.cmt + lib_ab/lib_ab.cmx + lib_ab/lib_ab.cmxa + lib_ab/lib_ab.ml + lib_apply/f.ml + lib_apply/lib_apply.a + lib_apply/lib_apply.cma + lib_apply/lib_apply.cmi + lib_apply/lib_apply.cmt + lib_apply/lib_apply.cmx + lib_apply/lib_apply.cmxa + lib_apply/lib_apply.ml + lib_apply/lib_apply__.cmi + lib_apply/lib_apply__.cmt + lib_apply/lib_apply__.cmx + lib_apply/lib_apply__.ml + lib_apply/lib_apply__F.cmi + lib_apply/lib_apply__F.cmt + lib_apply/lib_apply__F.cmx + lib_apply/lib_apply__X.cmi + lib_apply/lib_apply__X.cmt + lib_apply/lib_apply__X.cmx + lib_apply/lib_apply__Y.cmi + lib_apply/lib_apply__Y.cmt + lib_apply/lib_apply__Y.cmx + lib_apply/lib_apply__Z.cmi + lib_apply/lib_apply__Z.cmt + lib_apply/lib_apply__Z.cmx + lib_apply/x.ml + lib_apply/y.ml + lib_apply/z.ml)) + (libexec + (a_impl/a_impl.cmxs + a_of_b/a_of_b.cmxs + b_impl/b_impl.cmxs + b_impl2/b_impl2.cmxs + lib_ab/lib_ab.cmxs + lib_apply/lib_apply.cmxs)) + (bin (project.bin))) + (library + (name project.a) + (kind parameter) + (main_module_name A) + (modes byte) + (modules + (singleton + (obj_name a) + (visibility public) + (kind parameter) + (source (path A) (intf (path a/a.mli)))))) + (library + (name project.a_impl) + (kind normal) + (archives (byte a_impl/a_impl.cma) (native a_impl/a_impl.cmxa)) + (plugins (byte a_impl/a_impl.cma) (native a_impl/a_impl.cmxs)) + (native_archives a_impl/a_impl.a) + (requires project.a) + (implements project.a) + (main_module_name A_impl) + (modes byte native) + (modules + (wrapped + (group + (alias + (obj_name a_impl__a_impl__) + (visibility public) + (kind alias) + (source + (path A_impl__a_impl__) + (impl (path a_impl/a_impl__a_impl__.ml-gen)))) + (name A_impl) + (modules + (module + (obj_name a_impl) + (visibility public) + (source (path A_impl) (impl (path a_impl/a_impl.ml)))))) + (wrapped true)))) + (library + (name project.a_of_b) + (kind normal) + (archives (byte a_of_b/a_of_b.cma) (native a_of_b/a_of_b.cmxa)) + (plugins (byte a_of_b/a_of_b.cma) (native a_of_b/a_of_b.cmxs)) + (native_archives a_of_b/a_of_b.a) + (requires project.a project.b project.b) + (parameters project.b) + (implements project.a) + (main_module_name A_of_b) + (modes byte native) + (modules + (wrapped + (group + (alias + (obj_name a_of_b__a_of_b__) + (visibility public) + (kind alias) + (source + (path A_of_b__a_of_b__) + (impl (path a_of_b/a_of_b__a_of_b__.ml-gen)))) + (name A_of_b) + (modules + (module + (obj_name a_of_b) + (visibility public) + (source (path A_of_b) (impl (path a_of_b/a_of_b.ml)))))) + (wrapped true)))) + (library + (name project.b) + (kind parameter) + (main_module_name B) + (modes byte) + (modules + (singleton + (obj_name b) + (visibility public) + (kind parameter) + (source (path B) (intf (path b/b.mli)))))) + (library + (name project.b_impl) + (kind normal) + (archives (byte b_impl/b_impl.cma) (native b_impl/b_impl.cmxa)) + (plugins (byte b_impl/b_impl.cma) (native b_impl/b_impl.cmxs)) + (native_archives b_impl/b_impl.a) + (requires project.b) + (implements project.b) + (main_module_name B_impl) + (modes byte native) + (modules + (wrapped + (group + (alias + (obj_name b_impl__b_impl__) + (visibility public) + (kind alias) + (source + (path B_impl__b_impl__) + (impl (path b_impl/b_impl__b_impl__.ml-gen)))) + (name B_impl) + (modules + (module + (obj_name b_impl__B_dep) + (visibility public) + (source (path B_dep) (impl (path b_impl/b_dep.ml)))) + (module + (obj_name b_impl) + (visibility public) + (source (path B_impl) (impl (path b_impl/b_impl.ml)))))) + (wrapped true)))) + (library + (name project.b_impl2) + (kind normal) + (archives (byte b_impl2/b_impl2.cma) (native b_impl2/b_impl2.cmxa)) + (plugins (byte b_impl2/b_impl2.cma) (native b_impl2/b_impl2.cmxs)) + (native_archives b_impl2/b_impl2.a) + (requires project.b) + (implements project.b) + (main_module_name B_impl2) + (modes byte native) + (modules + (wrapped + (group + (alias + (obj_name b_impl2__b_impl2__) + (visibility public) + (kind alias) + (source + (path B_impl2__b_impl2__) + (impl (path b_impl2/b_impl2__b_impl2__.ml-gen)))) + (name B_impl2) + (modules + (module + (obj_name b_impl2) + (visibility public) + (source (path B_impl2) (impl (path b_impl2/b_impl2.ml)))))) + (wrapped true)))) + (library + (name project.lib_ab) + (kind normal) + (archives (byte lib_ab/lib_ab.cma) (native lib_ab/lib_ab.cmxa)) + (plugins (byte lib_ab/lib_ab.cma) (native lib_ab/lib_ab.cmxs)) + (native_archives lib_ab/lib_ab.a) + (requires (project.a_of_b) project.a project.b project.a project.b) + (parameters project.a project.b) + (main_module_name Lib_ab) + (modes byte native) + (modules + (singleton + (obj_name lib_ab) + (visibility public) + (source (path Lib_ab) (impl (path lib_ab/lib_ab.ml)))))) + (library + (name project.lib_apply) + (kind normal) + (archives (byte lib_apply/lib_apply.cma) (native lib_apply/lib_apply.cmxa)) + (plugins (byte lib_apply/lib_apply.cma) (native lib_apply/lib_apply.cmxs)) + (native_archives lib_apply/lib_apply.a) + (requires + project.a_impl + (project.lib_ab project.a_impl) + project.b_impl + (project.lib_ab project.a_impl project.b_impl) + (project.a_of_b) + (project.lib_ab project.a_of_b) + (project.lib_ab project.a_of_b project.b_impl) + project.b + project.b) + (parameters project.b) + (main_module_name Lib_apply) + (modes byte native) + (modules + (wrapped + (group + (alias + (obj_name lib_apply__) + (visibility public) + (kind alias) + (source (path Lib_apply__) (impl (path lib_apply/lib_apply__.ml-gen)))) + (name Lib_apply) + (modules + (module + (obj_name lib_apply__F) + (visibility public) + (source (path F) (impl (path lib_apply/f.ml)))) + (module + (obj_name lib_apply) + (visibility public) + (source (path Lib_apply) (impl (path lib_apply/lib_apply.ml)))) + (module + (obj_name lib_apply__X) + (visibility public) + (source (path X) (impl (path lib_apply/x.ml)))) + (module + (obj_name lib_apply__Y) + (visibility public) + (source (path Y) (impl (path lib_apply/y.ml)))) + (module + (obj_name lib_apply__Z) + (visibility public) + (source (path Z) (impl (path lib_apply/z.ml)))))) + (wrapped true)))) + +And all the required files should be installed: + + $ cat _build/default/project.install + lib: [ + "_build/install/default/lib/project/META" + "_build/install/default/lib/project/a/a.cmi" {"a/a.cmi"} + "_build/install/default/lib/project/a/a.cmti" {"a/a.cmti"} + "_build/install/default/lib/project/a/a.mli" {"a/a.mli"} + "_build/install/default/lib/project/a_impl/a_impl.a" {"a_impl/a_impl.a"} + "_build/install/default/lib/project/a_impl/a_impl.cma" {"a_impl/a_impl.cma"} + "_build/install/default/lib/project/a_impl/a_impl.cmi" {"a_impl/a_impl.cmi"} + "_build/install/default/lib/project/a_impl/a_impl.cmt" {"a_impl/a_impl.cmt"} + "_build/install/default/lib/project/a_impl/a_impl.cmx" {"a_impl/a_impl.cmx"} + "_build/install/default/lib/project/a_impl/a_impl.cmxa" {"a_impl/a_impl.cmxa"} + "_build/install/default/lib/project/a_impl/a_impl.ml" {"a_impl/a_impl.ml"} + "_build/install/default/lib/project/a_impl/a_impl__a_impl__.cmi" {"a_impl/a_impl__a_impl__.cmi"} + "_build/install/default/lib/project/a_impl/a_impl__a_impl__.cmt" {"a_impl/a_impl__a_impl__.cmt"} + "_build/install/default/lib/project/a_impl/a_impl__a_impl__.cmx" {"a_impl/a_impl__a_impl__.cmx"} + "_build/install/default/lib/project/a_impl/a_impl__a_impl__.ml" {"a_impl/a_impl__a_impl__.ml"} + "_build/install/default/lib/project/a_of_b/a_of_b.a" {"a_of_b/a_of_b.a"} + "_build/install/default/lib/project/a_of_b/a_of_b.cma" {"a_of_b/a_of_b.cma"} + "_build/install/default/lib/project/a_of_b/a_of_b.cmi" {"a_of_b/a_of_b.cmi"} + "_build/install/default/lib/project/a_of_b/a_of_b.cmt" {"a_of_b/a_of_b.cmt"} + "_build/install/default/lib/project/a_of_b/a_of_b.cmx" {"a_of_b/a_of_b.cmx"} + "_build/install/default/lib/project/a_of_b/a_of_b.cmxa" {"a_of_b/a_of_b.cmxa"} + "_build/install/default/lib/project/a_of_b/a_of_b.ml" {"a_of_b/a_of_b.ml"} + "_build/install/default/lib/project/a_of_b/a_of_b__a_of_b__.cmi" {"a_of_b/a_of_b__a_of_b__.cmi"} + "_build/install/default/lib/project/a_of_b/a_of_b__a_of_b__.cmt" {"a_of_b/a_of_b__a_of_b__.cmt"} + "_build/install/default/lib/project/a_of_b/a_of_b__a_of_b__.cmx" {"a_of_b/a_of_b__a_of_b__.cmx"} + "_build/install/default/lib/project/a_of_b/a_of_b__a_of_b__.ml" {"a_of_b/a_of_b__a_of_b__.ml"} + "_build/install/default/lib/project/b/b.cmi" {"b/b.cmi"} + "_build/install/default/lib/project/b/b.cmti" {"b/b.cmti"} + "_build/install/default/lib/project/b/b.mli" {"b/b.mli"} + "_build/install/default/lib/project/b_impl/b_dep.ml" {"b_impl/b_dep.ml"} + "_build/install/default/lib/project/b_impl/b_impl.a" {"b_impl/b_impl.a"} + "_build/install/default/lib/project/b_impl/b_impl.cma" {"b_impl/b_impl.cma"} + "_build/install/default/lib/project/b_impl/b_impl.cmi" {"b_impl/b_impl.cmi"} + "_build/install/default/lib/project/b_impl/b_impl.cmt" {"b_impl/b_impl.cmt"} + "_build/install/default/lib/project/b_impl/b_impl.cmx" {"b_impl/b_impl.cmx"} + "_build/install/default/lib/project/b_impl/b_impl.cmxa" {"b_impl/b_impl.cmxa"} + "_build/install/default/lib/project/b_impl/b_impl.ml" {"b_impl/b_impl.ml"} + "_build/install/default/lib/project/b_impl/b_impl__B_dep.cmi" {"b_impl/b_impl__B_dep.cmi"} + "_build/install/default/lib/project/b_impl/b_impl__B_dep.cmt" {"b_impl/b_impl__B_dep.cmt"} + "_build/install/default/lib/project/b_impl/b_impl__B_dep.cmx" {"b_impl/b_impl__B_dep.cmx"} + "_build/install/default/lib/project/b_impl/b_impl__b_impl__.cmi" {"b_impl/b_impl__b_impl__.cmi"} + "_build/install/default/lib/project/b_impl/b_impl__b_impl__.cmt" {"b_impl/b_impl__b_impl__.cmt"} + "_build/install/default/lib/project/b_impl/b_impl__b_impl__.cmx" {"b_impl/b_impl__b_impl__.cmx"} + "_build/install/default/lib/project/b_impl/b_impl__b_impl__.ml" {"b_impl/b_impl__b_impl__.ml"} + "_build/install/default/lib/project/b_impl2/b_impl2.a" {"b_impl2/b_impl2.a"} + "_build/install/default/lib/project/b_impl2/b_impl2.cma" {"b_impl2/b_impl2.cma"} + "_build/install/default/lib/project/b_impl2/b_impl2.cmi" {"b_impl2/b_impl2.cmi"} + "_build/install/default/lib/project/b_impl2/b_impl2.cmt" {"b_impl2/b_impl2.cmt"} + "_build/install/default/lib/project/b_impl2/b_impl2.cmx" {"b_impl2/b_impl2.cmx"} + "_build/install/default/lib/project/b_impl2/b_impl2.cmxa" {"b_impl2/b_impl2.cmxa"} + "_build/install/default/lib/project/b_impl2/b_impl2.ml" {"b_impl2/b_impl2.ml"} + "_build/install/default/lib/project/b_impl2/b_impl2__b_impl2__.cmi" {"b_impl2/b_impl2__b_impl2__.cmi"} + "_build/install/default/lib/project/b_impl2/b_impl2__b_impl2__.cmt" {"b_impl2/b_impl2__b_impl2__.cmt"} + "_build/install/default/lib/project/b_impl2/b_impl2__b_impl2__.cmx" {"b_impl2/b_impl2__b_impl2__.cmx"} + "_build/install/default/lib/project/b_impl2/b_impl2__b_impl2__.ml" {"b_impl2/b_impl2__b_impl2__.ml"} + "_build/install/default/lib/project/dune-package" + "_build/install/default/lib/project/lib_ab/lib_ab.a" {"lib_ab/lib_ab.a"} + "_build/install/default/lib/project/lib_ab/lib_ab.cma" {"lib_ab/lib_ab.cma"} + "_build/install/default/lib/project/lib_ab/lib_ab.cmi" {"lib_ab/lib_ab.cmi"} + "_build/install/default/lib/project/lib_ab/lib_ab.cmt" {"lib_ab/lib_ab.cmt"} + "_build/install/default/lib/project/lib_ab/lib_ab.cmx" {"lib_ab/lib_ab.cmx"} + "_build/install/default/lib/project/lib_ab/lib_ab.cmxa" {"lib_ab/lib_ab.cmxa"} + "_build/install/default/lib/project/lib_ab/lib_ab.ml" {"lib_ab/lib_ab.ml"} + "_build/install/default/lib/project/lib_apply/f.ml" {"lib_apply/f.ml"} + "_build/install/default/lib/project/lib_apply/lib_apply.a" {"lib_apply/lib_apply.a"} + "_build/install/default/lib/project/lib_apply/lib_apply.cma" {"lib_apply/lib_apply.cma"} + "_build/install/default/lib/project/lib_apply/lib_apply.cmi" {"lib_apply/lib_apply.cmi"} + "_build/install/default/lib/project/lib_apply/lib_apply.cmt" {"lib_apply/lib_apply.cmt"} + "_build/install/default/lib/project/lib_apply/lib_apply.cmx" {"lib_apply/lib_apply.cmx"} + "_build/install/default/lib/project/lib_apply/lib_apply.cmxa" {"lib_apply/lib_apply.cmxa"} + "_build/install/default/lib/project/lib_apply/lib_apply.ml" {"lib_apply/lib_apply.ml"} + "_build/install/default/lib/project/lib_apply/lib_apply__.cmi" {"lib_apply/lib_apply__.cmi"} + "_build/install/default/lib/project/lib_apply/lib_apply__.cmt" {"lib_apply/lib_apply__.cmt"} + "_build/install/default/lib/project/lib_apply/lib_apply__.cmx" {"lib_apply/lib_apply__.cmx"} + "_build/install/default/lib/project/lib_apply/lib_apply__.ml" {"lib_apply/lib_apply__.ml"} + "_build/install/default/lib/project/lib_apply/lib_apply__F.cmi" {"lib_apply/lib_apply__F.cmi"} + "_build/install/default/lib/project/lib_apply/lib_apply__F.cmt" {"lib_apply/lib_apply__F.cmt"} + "_build/install/default/lib/project/lib_apply/lib_apply__F.cmx" {"lib_apply/lib_apply__F.cmx"} + "_build/install/default/lib/project/lib_apply/lib_apply__X.cmi" {"lib_apply/lib_apply__X.cmi"} + "_build/install/default/lib/project/lib_apply/lib_apply__X.cmt" {"lib_apply/lib_apply__X.cmt"} + "_build/install/default/lib/project/lib_apply/lib_apply__X.cmx" {"lib_apply/lib_apply__X.cmx"} + "_build/install/default/lib/project/lib_apply/lib_apply__Y.cmi" {"lib_apply/lib_apply__Y.cmi"} + "_build/install/default/lib/project/lib_apply/lib_apply__Y.cmt" {"lib_apply/lib_apply__Y.cmt"} + "_build/install/default/lib/project/lib_apply/lib_apply__Y.cmx" {"lib_apply/lib_apply__Y.cmx"} + "_build/install/default/lib/project/lib_apply/lib_apply__Z.cmi" {"lib_apply/lib_apply__Z.cmi"} + "_build/install/default/lib/project/lib_apply/lib_apply__Z.cmt" {"lib_apply/lib_apply__Z.cmt"} + "_build/install/default/lib/project/lib_apply/lib_apply__Z.cmx" {"lib_apply/lib_apply__Z.cmx"} + "_build/install/default/lib/project/lib_apply/x.ml" {"lib_apply/x.ml"} + "_build/install/default/lib/project/lib_apply/y.ml" {"lib_apply/y.ml"} + "_build/install/default/lib/project/lib_apply/z.ml" {"lib_apply/z.ml"} + ] + libexec: [ + "_build/install/default/lib/project/a_impl/a_impl.cmxs" {"a_impl/a_impl.cmxs"} + "_build/install/default/lib/project/a_of_b/a_of_b.cmxs" {"a_of_b/a_of_b.cmxs"} + "_build/install/default/lib/project/b_impl/b_impl.cmxs" {"b_impl/b_impl.cmxs"} + "_build/install/default/lib/project/b_impl2/b_impl2.cmxs" {"b_impl2/b_impl2.cmxs"} + "_build/install/default/lib/project/lib_ab/lib_ab.cmxs" {"lib_ab/lib_ab.cmxs"} + "_build/install/default/lib/project/lib_apply/lib_apply.cmxs" {"lib_apply/lib_apply.cmxs"} + ] + bin: [ + "_build/install/default/bin/project.bin" + ] From 352cd44092674fe4ce09afa25fab5361df77504a Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 15 Oct 2025 10:38:52 +0200 Subject: [PATCH 02/26] fix: deduplicate dependencies Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 64 ++++++++----------- .../oxcaml/instantiate-parameterized.t | 13 ++-- .../oxcaml/library-field-parameters.t | 6 +- 3 files changed, 38 insertions(+), 45 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 1115d035287..0cb9307b528 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -1284,33 +1284,35 @@ end = struct in let* requires = let open Resolve.Memo.O in - let* requires = - Memo.return - @@ - let open Resolve.O in - let* resolved = resolved - and* resolved_params = parameters in - let+ requires = resolved.requires in - requires @ resolved_params - in - match implements with - | None -> Resolve.Memo.return requires - | Some impl -> - let* () = + let* resolved = Memo.return resolved in + let* requires = Memo.return resolved.requires in + let+ requires_params = Memo.return parameters + and+ requires_implements = + match implements with + | None -> Resolve.Memo.return [] + | Some impl -> let* impl = Memo.return impl in - match Lib_info.kind impl.info with - | Parameter -> Resolve.Memo.return () - | Virtual -> - let requires_for_closure_check = - List.filter requires ~f:(fun lib -> not (Ordering.is_eq (compare lib impl))) - in - check_forbidden - requires_for_closure_check - ~forbidden_libraries:(Map.singleton impl Loc.none) - | Dune_file _ -> - Code_error.raise "expected Virtual or Parameter" [ "implements", to_dyn impl ] - in - Resolve.Memo.return requires + (match Lib_info.kind impl.info with + | Parameter -> Resolve.Memo.return [ impl ] + | Virtual -> + let requires_for_closure_check = + List.filter requires ~f:(fun lib -> + not (Ordering.is_eq (compare lib impl))) + in + let+ () = + check_forbidden + requires_for_closure_check + ~forbidden_libraries:(Map.singleton impl Loc.none) + in + [] + | Dune_file _ -> + Code_error.raise + "expected Virtual or Parameter" + [ "implements", to_dyn impl ]) + in + List.concat [ requires_implements; requires_params; requires ] + |> Set.of_list + |> Set.to_list in let resolve_impl impl_name = let open Resolve.Memo.O in @@ -1357,16 +1359,6 @@ end = struct (Package.Name.to_string p') ]))) in - let* requires = - Memo.return - (let open Resolve.O in - let* requires = requires in - match implements with - | None -> Resolve.return requires - | Some impl -> - let+ impl = impl in - impl :: requires) - in let* ppx_runtime_deps = Lib_info.ppx_runtime_deps info |> resolve_simple_deps db ~private_deps in diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t index 6c22aef5135..ff4a6d4b3af 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t @@ -495,7 +495,7 @@ The `dune-package` should list the different instantiations in the dependencies: (archives (byte a_of_b/a_of_b.cma) (native a_of_b/a_of_b.cmxa)) (plugins (byte a_of_b/a_of_b.cma) (native a_of_b/a_of_b.cmxs)) (native_archives a_of_b/a_of_b.a) - (requires project.a project.b project.b) + (requires project.a project.b) (parameters project.b) (implements project.a) (main_module_name A_of_b) @@ -592,7 +592,7 @@ The `dune-package` should list the different instantiations in the dependencies: (archives (byte lib_ab/lib_ab.cma) (native lib_ab/lib_ab.cmxa)) (plugins (byte lib_ab/lib_ab.cma) (native lib_ab/lib_ab.cmxs)) (native_archives lib_ab/lib_ab.a) - (requires (project.a_of_b) project.a project.b project.a project.b) + (requires project.a (project.a_of_b) project.b) (parameters project.a project.b) (main_module_name Lib_ab) (modes byte native) @@ -609,14 +609,13 @@ The `dune-package` should list the different instantiations in the dependencies: (native_archives lib_apply/lib_apply.a) (requires project.a_impl - (project.lib_ab project.a_impl) + (project.a_of_b) + project.b project.b_impl + (project.lib_ab project.a_impl) (project.lib_ab project.a_impl project.b_impl) - (project.a_of_b) (project.lib_ab project.a_of_b) - (project.lib_ab project.a_of_b project.b_impl) - project.b - project.b) + (project.lib_ab project.a_of_b project.b_impl)) (parameters project.b) (main_module_name Lib_apply) (modes byte native) diff --git a/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t b/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t index 78057b419b6..e35ea56a575 100644 --- a/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t +++ b/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t @@ -340,7 +340,8 @@ required parameters. -> required by _build/default/bin/bin.exe -> required by alias bin/all -> required by alias default - Hint: Add (parameters project.a) + Hint: Pass an argument implementing project.a to the dependency, or add + (parameters project.a) [1] $ rm -r bin @@ -362,7 +363,8 @@ Same for libraries: -> required by _build/default/lib2/lib2.a -> required by alias lib2/all -> required by alias default - Hint: Add (parameters project.a) + Hint: Pass an argument implementing project.a to the dependency, or add + (parameters project.a) [1] It works if `lib2` is itself parameterized with the same parameters as `lib`: From 1ac0f3e1eb54fbaeead0eb965b80b0a312446d9a Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 15 Oct 2025 16:35:02 +0200 Subject: [PATCH 03/26] optimize dep_graph reuse Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 8 +- src/dune_rules/parameterized_rules.ml | 110 +++++++++++++++++--------- 2 files changed, 78 insertions(+), 40 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 0cb9307b528..f0b218434a8 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -715,9 +715,11 @@ module Parameterized = struct match status t with | Not_parameterized | Partial -> None | Complete -> - let parameterized_dir = Path.Build.relative build_dir ".parameterized" in - let subdir = parameterized_name t in - let dir = Path.Build.relative parameterized_dir subdir in + let parameterized_dir = Path.Build.(relative build_dir ".parameterized") in + let parameterized_dir = + Path.Build.relative parameterized_dir (Lib_name.to_string (name t)) + in + let dir = Path.Build.relative parameterized_dir (parameterized_name t) in Some (Lib_info.for_instance ~dir ~ext_lib t.info) ;; diff --git a/src/dune_rules/parameterized_rules.ml b/src/dune_rules/parameterized_rules.ml index 34dc4445a28..d46e61b3177 100644 --- a/src/dune_rules/parameterized_rules.ml +++ b/src/dune_rules/parameterized_rules.ml @@ -174,8 +174,7 @@ let apply_module_name module_ args = Parameterized_name.to_module_name { name; args } ;; -let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graphs ~mode ~requires ~lib modules - = +let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~lib modules = let kind = Lib_mode.Cm_kind.Ocaml (Mode.cm_kind mode) in let ext = Lib_mode.Cm_kind.ext kind in let cm_args = Lib.Parameterized.arguments lib |> Resolve.List.map ~f:(get_cm ~kind) in @@ -213,7 +212,7 @@ let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graphs ~mode ~requires ~l let hidden_deps = let open Action_builder.O in let+ lib_hidden_deps = lib_hidden_deps - and+ module_deps = Dep_graph.deps_of dep_graphs module_ in + and+ module_deps = Dep_graph.deps_of dep_graph module_ in let deps = List.map module_deps ~f:(fun module_ -> apply_module_name module_ args |> obj_file ~obj_dir ~kind |> Path.build) @@ -240,7 +239,32 @@ let iter_modes_concurrently ~(f : Ocaml.Mode.t -> unit Memo.t) = () ;; -let instantiate ~sctx lib = +let dep_graph ~obj_dir ~modules impl_only = + let per_module = + List.fold_left impl_only ~init:Module_name.Unique.Map.empty ~f:(fun acc module_ -> + let module_name_unique = Module.obj_name module_ in + let deps = + let open Action_builder.O in + let+ deps = + Dep_rules.read_immediate_deps_of module_ ~modules ~obj_dir ~ml_kind:Impl + in + let local_open = Modules.With_vlib.alias_for modules module_ in + local_open @ deps + in + Module_name.Unique.Map.add_exn acc module_name_unique deps) + in + Dep_graph.make ~dir:(Obj_dir.dir obj_dir) ~per_module +;; + +let obj_dir_for_dep_rules dir = + Obj_dir.make_lib + ~dir + ~has_private_modules:false + ~private_lib:false + (Lib_name.Local.of_string "deps") +;; + +let instantiate ~sctx ~dir lib = let ctx = Super_context.context sctx in let build_dir = Context.build_dir ctx in let* { Lib_config.ext_lib; _ } = @@ -248,16 +272,19 @@ let instantiate ~sctx lib = ocaml.lib_config in let lib_info = Lib.info lib in - let modules_obj_dir = Lib_info.obj_dir lib_info in - let* modules = + let* modules_obj_dir, modules = match Lib_info.modules lib_info with - | External (Some modules) -> Memo.return modules - | External None -> failwith "external None" + | External None -> Code_error.raise "library has no modules" [ "lib", Lib.to_dyn lib ] + | External (Some modules) -> + Memo.return (obj_dir_for_dep_rules (Path.Build.parent_exn dir), modules) | Local -> let local_lib = Lib.Local.of_lib_exn lib in let+ modules = Dir_contents.modules_of_local_lib sctx local_lib in - Modules.With_vlib.modules modules + let modules_obj_dir = Lib_info.obj_dir (Lib.Local.info local_lib) in + modules_obj_dir, Modules.With_vlib.modules modules in + let impl_only = Modules.With_vlib.impl_only modules in + let dep_graph = dep_graph ~obj_dir:modules_obj_dir ~modules impl_only in let* requires = Lib.closure ~linking:true [ lib ] |> Resolve.Memo.map @@ -265,29 +292,14 @@ let instantiate ~sctx lib = in let lib = Lib.Parameterized.for_instance ~build_dir ~ext_lib lib in let obj_dir = Lib_info.obj_dir (Lib.info lib) |> Obj_dir.as_local_exn in - let* dep_graphs = - let+ dg = - (* TODO art-w: If the lib is local, then don't recompute. If the lib is - global, then compute only once not once-per-instantiation. *) - Dep_rules.rules - ~dir:(Obj_dir.dir obj_dir) - ~sandbox:Sandbox_config.no_special_requirements - ~obj_dir - ~sctx - ~impl:Virtual_rules.no_implements - ~modules - in - dg.impl - in - let impl_only = Modules.With_vlib.impl_only modules in - let top_sorted_modules = Dep_graph.top_closed_implementations dep_graphs impl_only in + let top_sorted_modules = Dep_graph.top_closed_implementations dep_graph impl_only in iter_modes_concurrently ~f:(fun mode -> let* modules = build_modules ~sctx ~obj_dir - ~modules_obj_dir - ~dep_graphs + ~modules_obj_dir:(Obj_dir.of_local modules_obj_dir) + ~dep_graph ~mode ~requires ~lib @@ -296,13 +308,6 @@ let instantiate ~sctx lib = build_archive ~sctx ~mode ~obj_dir ~lib ~top_sorted_modules ~modules) ;; -let has_rules fn = - Memo.return - (Build_config.Gen_rules.make - ~directory_targets:Path.Build.Map.empty - (Rules.collect_unit fn)) -;; - let resolve_instantiation scope str = let db = Scope.libs scope in let rec go { Parameterized_name.name; args } = @@ -322,6 +327,36 @@ let resolve_instantiation scope str = go (Parameterized_name.of_string str) |> Resolve.Memo.read_memo ;; +let external_dep_rules ~sctx ~dir ~scope lib_name = + let* lib = + Lib.DB.find (Scope.libs scope) (Lib_name.of_string lib_name) + >>| function + | None -> Code_error.raise "not found" [ "lib", Dyn.string lib_name ] + | Some lib -> lib + in + match Lib_info.modules (Lib.info lib) with + | Local -> Memo.return () + | External None -> Code_error.raise "library has no modules" [ "lib", Lib.to_dyn lib ] + | External (Some modules) -> + let+ _ = + Dep_rules.rules + ~sctx + ~sandbox:Sandbox_config.no_special_requirements + ~dir + ~obj_dir:(obj_dir_for_dep_rules dir) + ~impl:Virtual_rules.no_implements + ~modules + in + () +;; + +let has_rules fn = + Memo.return + (Build_config.Gen_rules.make + ~directory_targets:Path.Build.Map.empty + (Rules.collect_unit fn)) +;; + let gen_rules ~sctx ~dir ~scope rest = match rest with | [] -> @@ -330,11 +365,12 @@ let gen_rules ~sctx ~dir ~scope rest = ~build_dir_only_sub_dirs: (Build_config.Gen_rules.Build_only_sub_dirs.singleton ~dir Subdir_set.all) (Memo.return Rules.empty)) - | [ folder ] -> + | [ lib_name ] -> has_rules @@ fun () -> external_dep_rules ~sctx ~dir ~scope lib_name + | [ _lib_name; instance_name ] when not (String.equal instance_name ".deps.objs") -> has_rules @@ fun () -> - let* lib = resolve_instantiation scope folder in - instantiate ~sctx lib + let* lib = resolve_instantiation scope instance_name in + instantiate ~sctx ~dir lib | _ -> Memo.return (Build_config.Gen_rules.redirect_to_parent Build_config.Gen_rules.Rules.empty) From 1be5c2d91d63ec62298eab5ee156b7f22e7a23bf Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 16 Oct 2025 09:49:33 +0200 Subject: [PATCH 04/26] test duplicate arguments Signed-off-by: ArthurW --- .../oxcaml/instantiate-parameterized.t | 41 ++++++++++++++++++- 1 file changed, 39 insertions(+), 2 deletions(-) diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t index ff4a6d4b3af..3796de96ea2 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t @@ -194,8 +194,7 @@ It's an error to provide a non-required parameter: Hint: Remove the extra argument [1] -Given another implementation of a parameter, we can instantiate the same -library multiple times by giving it different names: +Given another implementation of a parameter, $ mkdir b_impl2 $ echo 'let b = "b2"' > b_impl2/b_impl2.ml @@ -203,6 +202,44 @@ library multiple times by giving it different names: > (library (public_name project.b_impl2) (name b_impl2) (implements b)) > EOF +It's an error to instantiate a library with arguments that +implement the same parameter `b`, because it would be ambiguous +which one to use: + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > (lib_apply b_impl b_impl2))) + > EOF + $ dune exec project.bin + File "bin/dune", line 4, characters 22-29: + 4 | (lib_apply b_impl b_impl2))) + ^^^^^^^ + Error: Unexpected argument "project.b_impl2" + -> required by _build/install/default/bin/project.bin + Hint: Remove the extra argument + [1] + +Same error if the argument is repeated: + + $ cat >bin/dune < (executable + > (public_name project.bin) (name bin) + > (libraries + > (lib_apply b_impl b_impl))) + > EOF + $ dune exec project.bin + File "bin/dune", line 4, characters 22-28: + 4 | (lib_apply b_impl b_impl))) + ^^^^^^ + Error: Unexpected argument "project.b_impl" + -> required by _build/install/default/bin/project.bin + Hint: Remove the extra argument + [1] + +We can instantiate the same library multiple times by giving it different names: + $ cat >bin/dune < (executable > (public_name project.bin) (name bin) From bbe552913863c54f2099a8fbc99295be39db7954 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 16 Oct 2025 11:00:06 +0200 Subject: [PATCH 05/26] fixup dep_rules Signed-off-by: ArthurW --- src/dune_rules/parameterized_rules.ml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/dune_rules/parameterized_rules.ml b/src/dune_rules/parameterized_rules.ml index d46e61b3177..07ccdc19b08 100644 --- a/src/dune_rules/parameterized_rules.ml +++ b/src/dune_rules/parameterized_rules.ml @@ -264,7 +264,7 @@ let obj_dir_for_dep_rules dir = (Lib_name.Local.of_string "deps") ;; -let instantiate ~sctx ~dir lib = +let instantiate ~sctx lib = let ctx = Super_context.context sctx in let build_dir = Context.build_dir ctx in let* { Lib_config.ext_lib; _ } = @@ -272,11 +272,14 @@ let instantiate ~sctx ~dir lib = ocaml.lib_config in let lib_info = Lib.info lib in - let* modules_obj_dir, modules = + let modules_obj_dir = Lib_info.obj_dir lib_info in + let* deps_obj_dir, modules = match Lib_info.modules lib_info with | External None -> Code_error.raise "library has no modules" [ "lib", Lib.to_dyn lib ] | External (Some modules) -> - Memo.return (obj_dir_for_dep_rules (Path.Build.parent_exn dir), modules) + let dir = Path.Build.relative build_dir ".parameterized" in + let dir = Path.Build.relative dir (Lib_name.to_string (Lib.name lib)) in + Memo.return (obj_dir_for_dep_rules dir, modules) | Local -> let local_lib = Lib.Local.of_lib_exn lib in let+ modules = Dir_contents.modules_of_local_lib sctx local_lib in @@ -284,7 +287,7 @@ let instantiate ~sctx ~dir lib = modules_obj_dir, Modules.With_vlib.modules modules in let impl_only = Modules.With_vlib.impl_only modules in - let dep_graph = dep_graph ~obj_dir:modules_obj_dir ~modules impl_only in + let dep_graph = dep_graph ~obj_dir:deps_obj_dir ~modules impl_only in let* requires = Lib.closure ~linking:true [ lib ] |> Resolve.Memo.map @@ -298,7 +301,7 @@ let instantiate ~sctx ~dir lib = build_modules ~sctx ~obj_dir - ~modules_obj_dir:(Obj_dir.of_local modules_obj_dir) + ~modules_obj_dir ~dep_graph ~mode ~requires @@ -370,7 +373,7 @@ let gen_rules ~sctx ~dir ~scope rest = has_rules @@ fun () -> let* lib = resolve_instantiation scope instance_name in - instantiate ~sctx ~dir lib + instantiate ~sctx lib | _ -> Memo.return (Build_config.Gen_rules.redirect_to_parent Build_config.Gen_rules.Rules.empty) From ae98be28516b3d9f3efa7c3323b2092437afb127 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 16 Oct 2025 11:00:50 +0200 Subject: [PATCH 06/26] test: check external installation Signed-off-by: ArthurW --- .../oxcaml/install-parameterized.t/.run.t.swn | Bin 0 -> 12288 bytes .../external/dune-project | 6 ++ .../external/impl/dune | 4 ++ .../external/impl/impl.ml | 1 + .../external/impl2/dune | 4 ++ .../external/impl2/impl2.ml | 1 + .../install-parameterized.t/external/lib/dune | 6 ++ .../external/lib/lib.ml | 1 + .../external/param/dune | 3 + .../external/param/param.mli | 1 + .../external/paramlib/dune | 4 ++ .../external/paramlib/helper.ml | 1 + .../external/paramlib/paramlib.ml | 1 + .../oxcaml/install-parameterized.t/run.t | 66 ++++++++++++++++++ 14 files changed, 99 insertions(+) create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/.run.t.swn create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/dune-project create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/dune create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/impl.ml create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/dune create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/impl2.ml create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/dune create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/param.mli create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/dune create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/helper.ml create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/paramlib.ml create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/.run.t.swn b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/.run.t.swn new file mode 100644 index 0000000000000000000000000000000000000000..11f60cdc7799fbbceb6f04902fcc9fb489406a25 GIT binary patch literal 12288 zcmeI2&2QX97>6g7koYR!2g>Q~5@au`?Ifj$d{vY{`B1B*(w6o@w_|&fHSyXjdp6xr zHRS?AaO4U{KE#b)K|)BJ_yah>f54$a2#Es{zZu)J*`!Iu5tx;pI3ADRo%eZPTZ%H_ z%$u*Dr+I&t;qwS%f8M&?`(yj3sq2s4!z3?~Sd{9@p`Uu5*XbqM<{FQ^%d_4JFTyEQOd<{MY7r-2N0{r#>V?Tgz!8afU z7r+{L2{_;>@caFU13m}ugB>8i8(<#%g&e;JpMVd*yWl2Jxjzq1fi`e~1MJ5dum-FF zYrq(4paB4&5oom zg-I3wA14f#PSY!^XY~lUd>TSwcj%V=6@cQMW2WJ#wWmk7qd8*O7IMoxiQQhPFW$GB?aCg$FrZ5%@yw(!cq9;f-ukOdDbultF zWfCNr=Z6Xp#kewRr#6M#6Opdg)#;j$S0|0T!xB}XYWFwI__Iw{a*XO1$Vq>0W_L5H zL2ppxZ;MFQPp0-NMuWVNw7PQU{JFI=o!6FqKWJ(nbi-ki#?9{X04n$}l>t^))g-22 zDT-Zvs83m^Co;Nbo@P-!ziFx;^aYhk{l3@X$@7Xlmt&7F*1OpmJDU`Ee<4z<9%|7< qd)Jx}vZG#f)r(_SMaH$Ge0{9E)P*!|bp@(Wcv0&Dqd-U{_SxTRIh3CO literal 0 HcmV?d00001 diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/dune-project b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/dune-project new file mode 100644 index 00000000000..fa3fcf7b77b --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/dune-project @@ -0,0 +1,6 @@ +(lang dune 3.20) + +(using oxcaml 0.1) + +(package + (name external)) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/dune new file mode 100644 index 00000000000..72a4f97acc5 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/dune @@ -0,0 +1,4 @@ +(library + (public_name external.impl) + (name impl) + (implements param)) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/impl.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/impl.ml new file mode 100644 index 00000000000..ba4cb647c89 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/impl.ml @@ -0,0 +1 @@ +let v = "external.impl" diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/dune new file mode 100644 index 00000000000..8121702dd68 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/dune @@ -0,0 +1,4 @@ +(library + (public_name external.impl2) + (name impl2) + (implements param)) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/impl2.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/impl2.ml new file mode 100644 index 00000000000..07ecd9411a4 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/impl2.ml @@ -0,0 +1 @@ +let v = "external.impl2" diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune new file mode 100644 index 00000000000..c5d8762a915 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune @@ -0,0 +1,6 @@ +(library + (public_name external.lib) + (name lib) + (libraries + (paramlib impl) + (paramlib impl2 :as paramlib2))) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml new file mode 100644 index 00000000000..f456c7fd1b9 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml @@ -0,0 +1 @@ +let test () = String.uppercase_ascii (Paramlib.v ^ " " ^ Paramlib2.v) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/dune new file mode 100644 index 00000000000..cbaebb93870 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/dune @@ -0,0 +1,3 @@ +(library_parameter + (public_name external.param) + (name param)) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/param.mli b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/param.mli new file mode 100644 index 00000000000..df836d4b42f --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/param.mli @@ -0,0 +1 @@ +val v : string diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/dune new file mode 100644 index 00000000000..a0250cfa703 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/dune @@ -0,0 +1,4 @@ +(library + (public_name external.paramlib) + (name paramlib) + (parameters param)) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/helper.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/helper.ml new file mode 100644 index 00000000000..5b49b7c64df --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/helper.ml @@ -0,0 +1 @@ +let v = "helper(" ^ Param.v ^ ")" diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/paramlib.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/paramlib.ml new file mode 100644 index 00000000000..85531f1cf06 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/paramlib.ml @@ -0,0 +1 @@ +let v = "paramlib(" ^ Helper.v ^ ")" diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t new file mode 100644 index 00000000000..236ba57dd6f --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t @@ -0,0 +1,66 @@ +Test that an external definition of parameters and parameterized libraries can be used. + +First we "install" the external library: + + $ dune build --root external @install + Entering directory 'external' + Leaving directory 'external' + +Then we test the installation: + + $ mkdir user + $ cd user + $ export OCAMLPATH=../external/_build/install/default/lib + + $ cat > dune-project < (lang dune 3.20) + > (using oxcaml 0.1) + > EOF + +We test that a library can be parameterized by an external `library_parameter` +definition, and can implement an external parameter too: + + $ mkdir other_impl + $ echo 'let v = "other(" ^ Param.v ^ ")"' > other_impl/other_impl.ml + $ cat > other_impl/dune < (library (name other_impl) + > (parameters external.param) + > (implements external.param)) + > EOF + +We test that a library can instantiate with an external argument implementing +the external parameter: + + $ mkdir other_ext + $ echo 'let v = "compose(" ^ Other_impl.v ^ ")"' > other_ext/other_ext.ml + $ cat > other_ext/dune < (library (name other_ext) + > (implements external.param) + > (libraries (other_impl external.impl))) + > EOF + +We test that a binary can instantiate external libraries, with either external +and local implementations: + + $ mkdir bin + $ cat > bin/bin.ml < let () = + > print_endline Paramlib_impl.v ; + > print_endline Paramlib_otherext.v ; + > print_endline (Lib.test ()) ; + > print_endline Other_ext.v + > EOF + $ cat > bin/dune < (executable (name bin) + > (libraries + > (external.paramlib external.impl :as paramlib_impl) + > (external.paramlib other_ext :as paramlib_otherext) + > external.lib ; has instances + > other_ext)) + > EOF + + $ dune exec bin/bin.exe + paramlib(helper(external.impl)) + paramlib(helper(compose(other(external.impl)))) + PARAMLIB(HELPER(EXTERNAL.IMPL)) PARAMLIB(HELPER(EXTERNAL.IMPL2)) + compose(other(external.impl)) From 3cf5e3db60cab94851f5b1c9e11a1f39868920a8 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 16 Oct 2025 11:02:56 +0200 Subject: [PATCH 07/26] fixup deprules Signed-off-by: ArthurW --- .../oxcaml/instantiate-exponential.t | 36 +++++++------------ 1 file changed, 12 insertions(+), 24 deletions(-) diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t index 44a60dea58c..3779fecbda3 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t @@ -52,23 +52,18 @@ instantiated library names. For dune folders, the number of exclamation points indicates the level of application nesting, i.e. `f!g!!x = f(g(x))` and `f!g!x = f(g)(x)`. +The instantiated libraries are collected in .parameterized: + $ ls _build/default/.parameterized - f!f!!g!!!h!!!!i!!!!!x_impl - f!f!!g!!!h!!!!x_impl - f!f!!g!!!i!!!!x_impl - f!f!!g!!!x_impl - f!f!!h!!!i!!!!x_impl - f!f!!h!!!x_impl - f!f!!i!!!x_impl - f!f!!x_impl - f!g!!h!!!i!!!!x_impl - f!g!!h!!!x_impl - f!g!!i!!!x_impl - f!g!!x_impl - f!h!!i!!!x_impl - f!h!!x_impl - f!i!!x_impl - f!x_impl + f + g + h + i + j + +With each lib folder containing the list of its instances: + + $ ls _build/default/.parameterized/g g!g!!h!!!i!!!!x_impl g!g!!h!!!x_impl g!g!!i!!!x_impl @@ -77,17 +72,10 @@ indicates the level of application nesting, i.e. `f!g!!x = f(g(x))` and `f!g!x g!h!!x_impl g!i!!x_impl g!x_impl - h!h!!i!!!x_impl - h!h!!x_impl - h!i!!x_impl - h!x_impl - i!i!!x_impl - i!x_impl - j!x_impl For modules instantiated by the compiler, a dash is used: - $ ls _build/default/.parameterized/f!f!!g!!!h!!!!i!!!!!x_impl/.instance.objs/native + $ ls _build/default/.parameterized/f/f!f!!g!!!h!!!!i!!!!!x_impl/.instance.objs/native f-F--G---H----I-----X_impl.cmx f-F--G---H----I-----X_impl.o f__f__-F--G---H----I-----X_impl.cmx From 12d73fe8689fefc4b80ca913f0b40a97f6fa89a0 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 17 Oct 2025 10:41:05 +0200 Subject: [PATCH 08/26] fix: instantiation of unwrapped libs Signed-off-by: ArthurW --- src/dune_rules/compilation_context.ml | 2 +- src/dune_rules/compilation_context.mli | 4 +- src/dune_rules/exe_rules.ml | 4 +- src/dune_rules/lib.ml | 84 +---------- src/dune_rules/lib.mli | 8 - src/dune_rules/lib_rules.ml | 4 +- src/dune_rules/ml_sources.ml | 3 +- src/dune_rules/module_compilation.ml | 15 +- src/dune_rules/modules.ml | 1 - src/dune_rules/parameterized_rules.ml | 112 +++++++++++++- src/dune_rules/parameterized_rules.mli | 10 ++ .../external/unwrapped_lib/dune | 5 + .../external/unwrapped_lib/unwrapped_a.ml | 1 + .../external/unwrapped_lib/unwrapped_b.ml | 1 + .../oxcaml/install-parameterized.t/run.t | 8 +- .../oxcaml/unwrapped-with-instantiate.t | 137 ++++++++++++++++++ 16 files changed, 285 insertions(+), 114 deletions(-) create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/dune create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_a.ml create mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_b.ml create mode 100644 test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t diff --git a/src/dune_rules/compilation_context.ml b/src/dune_rules/compilation_context.ml index 4dcc751ae61..d15d1e88d93 100644 --- a/src/dune_rules/compilation_context.ml +++ b/src/dune_rules/compilation_context.ml @@ -89,7 +89,7 @@ type t = ; requires_link : Lib.t list Resolve.t Memo.Lazy.t ; implements : Virtual_rules.t ; parameters : Module_name.t list Resolve.Memo.t - ; instances : Lib.Parameterized.instance list Resolve.Memo.t + ; instances : Parameterized_rules.instances list Resolve.Memo.t ; includes : Includes.t ; preprocessing : Pp_spec.t ; opaque : bool diff --git a/src/dune_rules/compilation_context.mli b/src/dune_rules/compilation_context.mli index cf611742245..a7c2638219c 100644 --- a/src/dune_rules/compilation_context.mli +++ b/src/dune_rules/compilation_context.mli @@ -38,7 +38,7 @@ val create -> ?modes:Mode_conf.Set.Details.t Lib_mode.Map.t -> ?bin_annot:bool -> ?loc:Loc.t - -> ?instances:Lib.Parameterized.instance list Resolve.Memo.t + -> ?instances:Parameterized_rules.instances list Resolve.Memo.t -> unit -> t Memo.t @@ -91,4 +91,4 @@ val dep_graphs : t -> Dep_graph.t Ml_kind.Dict.t val loc : t -> Loc.t option val set_obj_dir : t -> Path.Build.t Obj_dir.t -> t val set_modes : t -> modes:Lib_mode.Map.Set.t -> t -val instances : t -> Lib.Parameterized.instance list Resolve.Memo.t +val instances : t -> Parameterized_rules.instances list Resolve.Memo.t diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml index cd11975623a..3b5dbc5b14f 100644 --- a/src/dune_rules/exe_rules.ml +++ b/src/dune_rules/exe_rules.ml @@ -184,7 +184,9 @@ let executables_rules let* cctx = let requires_compile = Lib.Compile.direct_requires compile_info in let requires_link = Lib.Compile.requires_link compile_info in - let instances = Lib.Compile.instances compile_info in + let instances = + Parameterized_rules.instances ~sctx ~db:(Scope.libs scope) exes.buildable.libraries + in let js_of_ocaml = Js_of_ocaml.Mode.Pair.mapi js_of_ocaml ~f:(fun mode x -> Option.some_if diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index f0b218434a8..db7bcbdc039 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -368,12 +368,6 @@ end = struct module Top_closure = Top_closure.Make (Set) (Resolve.Memo) end -type instance = - { new_name : Module_name.t - ; lib_name : Module_name.t - ; args : (Module_name.t * Module_name.t) list - } - module T = struct type t = { info : Lib_info.external_ @@ -388,7 +382,6 @@ module T = struct ; resolved_selects : Resolved_select.t list Resolve.t ; parameters : t list Resolve.t ; arguments : argument option list - ; instances : instance list Resolve.t ; implements : t Resolve.t option ; project : Dune_project.t option ; (* these fields cannot be forced until the library is instantiated *) @@ -539,12 +532,6 @@ module Parameterized = struct ; loc : Loc.t } - type nonrec instance = instance = - { new_name : Module_name.t - ; lib_name : Module_name.t - ; args : (Module_name.t * Module_name.t) list - } - type status = | Not_parameterized | Partial @@ -597,33 +584,6 @@ module Parameterized = struct { t with arguments } ;; - let make_instance lib ~new_name = - let open Resolve.O in - let* lib = lib in - let* lib_name = resolve_main_module_name lib in - let lib_name = Option.value_exn lib_name in - let new_name = - match new_name with - | None -> lib_name - | Some m -> m - in - let+ arguments = - let* lib_arguments = parameterized_arguments lib in - Resolve.List.filter_map lib_arguments ~f:(function - | _, None -> Resolve.return None - | param, Some { arg; _ } -> - let+ param_name = resolve_main_module_name param - and+ arg_name = resolve_main_module_name arg in - (match param_name, arg_name with - | Some param_name, Some arg_name -> Some (param_name, arg_name) - | _ -> - Code_error.raise - "expected argument to have a main module name" - [ "arg", to_dyn arg ])) - in - { new_name; lib_name; args = arguments } - ;; - let make_argument (loc, arg) = let open Resolve.O in let* arg = arg in @@ -1154,7 +1114,6 @@ module rec Resolve_names : sig ; pps : lib list Resolve.t ; selects : Resolved_select.t list ; re_exports : lib list Resolve.t - ; instances : Parameterized.instance list Resolve.t } end @@ -1386,7 +1345,6 @@ end = struct let resolved_selects = resolved >>| fun r -> r.selects in let pps = resolved >>= fun r -> r.pps in let re_exports = resolved >>= fun r -> r.re_exports in - let instances = resolved >>= fun r -> r.instances in { info ; name ; unique_id @@ -1395,7 +1353,6 @@ end = struct ; pps ; resolved_selects ; re_exports - ; instances ; implements ; parameters ; arguments = List.map ~f:(fun _ -> None) (Lib_info.parameters info) @@ -1634,7 +1591,6 @@ end = struct { resolved : t list Resolve.t ; selects : Resolved_select.t list ; re_exports : t list Resolve.t - ; instances : Parameterized.instance list Resolve.t } type t = @@ -1642,7 +1598,6 @@ end = struct ; pps : lib list Resolve.t ; selects : Resolved_select.t list ; re_exports : lib list Resolve.t - ; instances : Parameterized.instance list Resolve.t } module Builder : sig @@ -1652,7 +1607,6 @@ end = struct val add_resolved : t -> lib Resolve.t -> t val add_re_exports : t -> lib Resolve.t -> t val add_select : t -> lib list Resolve.t -> Resolved_select.t -> t - val add_instance : t -> Parameterized.instance Resolve.t -> t val value : t -> deps end = struct open Resolve.O @@ -1660,11 +1614,7 @@ end = struct type nonrec t = deps let empty = - { resolved = Resolve.return [] - ; selects = [] - ; re_exports = Resolve.return [] - ; instances = Resolve.return [] - } + { resolved = Resolve.return []; selects = []; re_exports = Resolve.return [] } ;; let add_resolved_list t resolved = @@ -1696,16 +1646,7 @@ end = struct add_resolved { t with re_exports } lib ;; - let add_instance (t : t) instance = - let instances = - let+ instance = instance - and+ instances = t.instances in - instance :: instances - in - { t with instances } - ;; - - let value { resolved; selects; re_exports; instances } = + let value { resolved; selects; re_exports } = let resolved = let+ resolved = resolved in List.rev resolved @@ -1714,7 +1655,7 @@ end = struct let+ re_exports = re_exports in List.rev re_exports in - { resolved; selects; re_exports; instances } + { resolved; selects; re_exports } ;; end end @@ -1770,7 +1711,7 @@ end = struct | Select select -> let+ resolved, select = resolve_select db ~private_deps select in Resolved.Builder.add_select acc resolved select - | Instantiate { loc; new_name; lib; arguments; _ } -> + | Instantiate { loc; lib; arguments; new_name = _ } -> let* arguments = Memo.List.filter_map arguments ~f:(fun (loc, dep) -> resolve_parameterized_dep (loc, dep) ~arguments:[] @@ -1783,9 +1724,7 @@ end = struct resolve_parameterized_dep (loc, lib) ~arguments >>| (function | None -> acc - | Some lib -> - let acc = Resolved.Builder.add_resolved acc lib in - Resolved.Builder.add_instance acc (Parameterized.make_instance lib ~new_name))) + | Some lib -> Resolved.Builder.add_resolved acc lib)) |> Memo.map ~f:Resolved.Builder.value ;; @@ -1844,7 +1783,7 @@ end = struct let add_pp_runtime_deps db - { Resolved.resolved; selects; re_exports; instances } + { Resolved.resolved; selects; re_exports } ~private_deps ~parameters ~pps @@ -1859,7 +1798,7 @@ end = struct let* runtime_deps = runtime_deps in re_exports_closure (List.concat [ resolved; runtime_deps; parameters ]) and+ pps = pps in - { Resolved.requires; pps; selects; re_exports; instances } + { Resolved.requires; pps; selects; re_exports } ;; let resolve_deps_and_add_runtime_deps @@ -2202,7 +2141,6 @@ module Compile = struct type nonrec t = { direct_requires : t list Resolve.Memo.t - ; instances : Parameterized.instance list Resolve.Memo.t ; requires_link : t list Resolve.t Memo.Lazy.t ; pps : t list Resolve.Memo.t ; resolved_selects : Resolved_select.t list Resolve.Memo.t @@ -2231,7 +2169,6 @@ module Compile = struct ~forbidden_libraries:Map.empty) in { direct_requires = requires - ; instances = Memo.return t.instances ; requires_link ; resolved_selects = Memo.return t.resolved_selects ; pps = Memo.return t.pps @@ -2240,7 +2177,6 @@ module Compile = struct ;; let direct_requires t = t.direct_requires - let instances t = t.instances let requires_link t = t.requires_link let resolved_selects t = t.resolved_selects let pps t = t.pps @@ -2503,13 +2439,7 @@ module DB = struct let+ resolved = Memo.Lazy.force resolved in resolved.selects in - let instances = - let open Memo.O in - let+ resolved = Memo.Lazy.force resolved in - resolved.instances - in { Compile.direct_requires - ; instances ; requires_link ; pps ; resolved_selects = resolved_selects |> Memo.map ~f:Resolve.return diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index 1dbd99d4417..4f8d9bd5596 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -41,12 +41,6 @@ module Parameterized : sig -> (Loc.t * t Resolve.t) list -> parent_parameters:t list -> t Resolve.t - - type instance = private - { new_name : Module_name.t - ; lib_name : Module_name.t - ; args : (Module_name.t * Module_name.t) list - } end (** [is_local t] returns [true] whenever [t] is defined in the local workspace *) @@ -99,8 +93,6 @@ module Compile : sig (** Dependencies listed by the user + runtime dependencies from ppx *) val direct_requires : t -> lib list Resolve.Memo.t - val instances : t -> Parameterized.instance list Resolve.Memo.t - module Resolved_select : sig type t = { src_fn : Filename.t Resolve.t diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index 3c9f9a343bf..647592c235a 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -512,7 +512,9 @@ let cctx let modules = Virtual_rules.impl_modules implements modules in let requires_compile = Lib.Compile.direct_requires compile_info in let requires_link = Lib.Compile.requires_link compile_info in - let instances = Lib.Compile.instances compile_info in + let instances = + Parameterized_rules.instances ~sctx ~db:(Scope.libs scope) lib.buildable.libraries + in let* modes = let+ ocaml = let ctx = Super_context.context sctx in diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index 7281c365aa6..de1eec9aeeb 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -402,6 +402,8 @@ let make_lib_modules in kind, main_module_name, wrapped in + let has_instances = has_instances lib.buildable in + let wrapped = if has_instances then Wrapped.Simple true else wrapped in let open Memo.O in let* sources, modules = let { Buildable.loc = stanza_loc; modules = modules_settings; _ } = lib.buildable in @@ -444,7 +446,6 @@ let make_lib_modules in let implements = Option.is_some lib.implements in let _loc, lib_name = lib.name in - let has_instances = has_instances lib.buildable in Resolve.Memo.return ( sources , Modules.lib diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index cdf51f6de16..1655e9624c5 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -465,7 +465,7 @@ module Alias_module = struct type t = { aliases : alias list ; shadowed : Module_name.t list - ; instances : Lib.Parameterized.instance list + ; instances : Parameterized_rules.instances list } let to_ml { aliases; shadowed; instances } = @@ -486,18 +486,7 @@ module Alias_module = struct b "\nmodule %s = struct end\n[@@deprecated \"this module is shadowed\"]\n" (Module_name.to_string shadowed)); - List.iter instances ~f:(fun (instance : Lib.Parameterized.instance) -> - Printf.bprintf - b - "\nmodule %s = %s%s [@jane.non_erasable.instances]" - (Module_name.to_string instance.new_name) - (Module_name.to_string instance.lib_name) - (String.concat ~sep:"" - @@ List.map instance.args ~f:(fun (param_name, arg_name) -> - Printf.sprintf - "(%s)(%s)" - (Module_name.to_string param_name) - (Module_name.to_string arg_name)))); + Parameterized_rules.print_instances b instances; Buffer.contents b ;; diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index 7a3b440ebbb..2aa25b2f1cb 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -802,7 +802,6 @@ let lib ~has_instances ~modules = - (* TODO art-w: if [has_instances] is true, then we always need an alias file *) let make_wrapped main_module_name = Wrapped (Wrapped.make ~obj_dir ~lib_name ~implements ~modules ~main_module_name ~wrapped) diff --git a/src/dune_rules/parameterized_rules.ml b/src/dune_rules/parameterized_rules.ml index 07ccdc19b08..59b96945c21 100644 --- a/src/dune_rules/parameterized_rules.ml +++ b/src/dune_rules/parameterized_rules.ml @@ -147,9 +147,7 @@ let build_archive ~sctx ~mode ~obj_dir ~lib ~top_sorted_modules ~modules = |> Super_context.add_rule ~dir sctx) ;; -let lib_hidden_deps ~kind lib requires = - Action_builder.of_memo - @@ +let lib_hidden_deps ~sctx ~kind lib requires = let* requires = Resolve.read_memo requires in Memo.List.concat_map requires ~f:(fun dep -> match Lib.compare lib dep with @@ -164,8 +162,27 @@ let lib_hidden_deps ~kind lib requires = "unexpected partial application" [ "lib", Lib.to_dyn lib; "dep", Lib.to_dyn dep ] | Not_parameterized -> - let+ cmi = Resolve.read_memo (get_cm ~kind:(Ocaml Cmi) dep) in - [ cmi ])) + let lib = dep in + let lib_info = Lib.info dep in + let obj_dir = Lib_info.obj_dir lib_info in + let+ modules = + match Lib_info.modules lib_info with + | External None -> + Code_error.raise "dependency has no modules" [ "lib", Lib.to_dyn dep ] + | External (Some modules) -> Memo.return modules + | Local -> + let local_lib = Lib.Local.of_lib_exn lib in + let+ modules = Dir_contents.modules_of_local_lib sctx local_lib in + Modules.With_vlib.modules modules + in + Modules.With_vlib.fold_no_vlib_with_aliases + modules + ~init:[] + ~normal:(fun module_ acc -> + match Obj_dir.Module.cm_file obj_dir module_ ~kind:(Ocaml Cmi) with + | None -> acc + | Some cmi -> cmi :: acc) + ~alias:(fun _group acc -> acc))) >>| Dep.Set.of_files ;; @@ -182,7 +199,7 @@ let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~li let+ ocaml = Super_context.context sctx |> Context.ocaml in ocaml.lib_config in - let lib_hidden_deps = lib_hidden_deps ~kind lib requires in + let* lib_hidden_deps = lib_hidden_deps ~sctx ~kind lib requires in let* args = (* The main module names of applied arguments is required because it's used in the instantiated filenames. @@ -211,8 +228,7 @@ let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~li in let hidden_deps = let open Action_builder.O in - let+ lib_hidden_deps = lib_hidden_deps - and+ module_deps = Dep_graph.deps_of dep_graph module_ in + let+ module_deps = Dep_graph.deps_of dep_graph module_ in let deps = List.map module_deps ~f:(fun module_ -> apply_module_name module_ args |> obj_file ~obj_dir ~kind |> Path.build) @@ -378,3 +394,83 @@ let gen_rules ~sctx ~dir ~scope rest = Memo.return (Build_config.Gen_rules.redirect_to_parent Build_config.Gen_rules.Rules.empty) ;; + +type instance = + { new_name : Module_name.t + ; lib_name : Module_name.t + ; args : (Module_name.t * Module_name.t) list + } + +type instances = + | Simple of instance + | Wrapped of Module_name.t * instance list + +let instances ~sctx ~db (deps : Lib_dep.t list) = + let open Resolve.Memo.O in + Resolve.Memo.List.concat_map deps ~f:(function + | Lib_dep.Direct _ | Lib_dep.Re_export _ | Lib_dep.Select _ -> Resolve.Memo.return [] + | Lib_dep.Instantiate { loc = _; lib; arguments; new_name } -> + let+ entry_names = + let* lib = Resolve.Memo.lift_memo @@ Lib.DB.find db lib in + match lib with + | None -> Resolve.Memo.return [] + | Some lib -> Root_module.entry_module_names sctx lib + and+ args = + Resolve.Memo.List.filter_map arguments ~f:(fun (_loc, arg_name) -> + let* arg = Resolve.Memo.lift_memo @@ Lib.DB.find db arg_name in + match arg with + | None -> Resolve.Memo.return None + | Some arg -> + (match Lib.implements arg with + | None -> Resolve.Memo.return None + | Some param -> + let* param = param in + let+ param_name = Lib.main_module_name param + and+ arg_name = Lib.main_module_name arg in + (match param_name, arg_name with + | Some param_name, Some arg_name -> Some (param_name, arg_name) + | _ -> None))) + in + (match entry_names with + | [] -> [] + | [ entry_name ] -> + let new_name = + match new_name with + | None -> entry_name + | Some new_name -> new_name + in + [ Simple { new_name; lib_name = entry_name; args } ] + | _ :: _ :: _ -> + let instances = + List.map entry_names ~f:(fun name -> + { new_name = name; lib_name = name; args }) + in + (match new_name with + | None -> List.map ~f:(fun i -> Simple i) instances + | Some new_name -> [ Wrapped (new_name, instances) ]))) +;; + +let print_instance b indent instance = + Printf.bprintf + b + "\n%smodule %s = %s%s [@jane.non_erasable.instances]" + indent + (Module_name.to_string instance.new_name) + (Module_name.to_string instance.lib_name) + (String.concat ~sep:"" + @@ List.map instance.args ~f:(fun (param_name, arg_name) -> + Printf.sprintf + "(%s)(%s)" + (Module_name.to_string param_name) + (Module_name.to_string arg_name))) +;; + +let print_instances b instances = + List.iter instances ~f:(fun instances -> + match instances with + | Simple instance -> print_instance b "" instance + | Wrapped (new_name, instances) -> + Printf.bprintf b "\nmodule %s = struct" (Module_name.to_string new_name); + List.iter instances ~f:(print_instance b " "); + Printf.bprintf b "\nend\n") +;; diff --git a/src/dune_rules/parameterized_rules.mli b/src/dune_rules/parameterized_rules.mli index 4d9cc111cb0..07dce765973 100644 --- a/src/dune_rules/parameterized_rules.mli +++ b/src/dune_rules/parameterized_rules.mli @@ -6,3 +6,13 @@ val gen_rules -> scope:Scope.t -> string list -> Build_config.Gen_rules.result Memo.t + +type instances + +val instances + : sctx:Super_context.t + -> db:Lib.db + -> Lib_dep.t list + -> instances list Resolve.Memo.t + +val print_instances : Buffer.t -> instances list -> unit diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/dune new file mode 100644 index 00000000000..1ae597de457 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/dune @@ -0,0 +1,5 @@ +(library + (public_name external.unwrapped_lib) + (name unwrapped_lib) + (wrapped false) + (parameters param)) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_a.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_a.ml new file mode 100644 index 00000000000..e6c2652be55 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_a.ml @@ -0,0 +1 @@ +let a = "unwrapped_a:" ^ Param.v diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_b.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_b.ml new file mode 100644 index 00000000000..4094fab3c5e --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_b.ml @@ -0,0 +1 @@ +let b = "unwrapped_b:" ^ Param.v diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t index 236ba57dd6f..5c6064d34e8 100644 --- a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t @@ -48,6 +48,8 @@ and local implementations: > print_endline Paramlib_impl.v ; > print_endline Paramlib_otherext.v ; > print_endline (Lib.test ()) ; + > print_endline (Unwrapped_a.a ^ "," ^ Unwrapped_b.b) ; + > print_endline (Rewrap.Unwrapped_a.a ^ "," ^ Rewrap.Unwrapped_b.b) ; > print_endline Other_ext.v > EOF $ cat > bin/dune < (libraries > (external.paramlib external.impl :as paramlib_impl) > (external.paramlib other_ext :as paramlib_otherext) - > external.lib ; has instances + > external.lib ; has instances internally + > (external.unwrapped_lib external.impl) + > (external.unwrapped_lib other_ext :as rewrap) > other_ext)) > EOF @@ -63,4 +67,6 @@ and local implementations: paramlib(helper(external.impl)) paramlib(helper(compose(other(external.impl)))) PARAMLIB(HELPER(EXTERNAL.IMPL)) PARAMLIB(HELPER(EXTERNAL.IMPL2)) + unwrapped_a:external.impl,unwrapped_b:external.impl + unwrapped_a:compose(other(external.impl)),unwrapped_b:compose(other(external.impl)) compose(other(external.impl)) diff --git a/test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t b/test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t new file mode 100644 index 00000000000..1edd97ccf49 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t @@ -0,0 +1,137 @@ +Test that unwrapped libraries can use instantation of parameterized libraries. + + $ cat > dune-project < (lang dune 3.20) + > (using oxcaml 0.1) + > EOF + +We define a parameter: + + $ mkdir param + $ echo 'val v : string' > param/param.mli + $ cat > param/dune < (library_parameter (name param)) + > EOF + +And an implementation of this parameter: + + $ mkdir impl + $ echo 'let v = "impl"' > impl/helper.ml + $ echo 'let v = Helper.v' > impl/impl.ml + $ cat > impl/dune < (library (name impl) (implements param)) + > EOF + + $ dune build + +It's an error for the implementation to be unwrapped, since it must +exactly implement the parameter signature (a single mli): + + $ cat > impl/dune < (library + > (name impl) + > (implements param) + > (wrapped false)) + > EOF + + $ dune build + File "impl/dune", line 4, characters 11-16: + 4 | (wrapped false)) + ^^^^^ + Error: Wrapped cannot be set for implementations. It is inherited from the + virtual library. + [1] + + $ cat > impl/dune < (library (name impl) (implements param)) + > EOF + +A parameterized library: + + $ mkdir lib + $ echo 'let v () = "helper:" ^ String.uppercase_ascii Param.v' > lib/helper.ml + $ echo 'let v () = "lib:" ^ Helper.v ()' > lib/lib.ml + $ cat > lib/dune < (library (name lib) (parameters param)) + > EOF + +And an executable: + + $ mkdir bin + $ echo 'let a () = Util.util ()' > bin/a.ml + $ echo 'let util () = print_endline (Lib.v ())' > bin/util.ml + $ echo 'let () = A.a ()' > bin/bin.ml + $ cat > bin/dune < (executable (name bin) (libraries (lib impl))) + > EOF + + $ dune exec ./bin/bin.exe + lib:helper:IMPL + +The library can be unwrapped: + + $ cat > lib/dune < (library (name lib) (parameters param) (wrapped false)) + > EOF + + $ dune exec ./bin/bin.exe + lib:helper:IMPL + +The binary also has access to `lib` Helper module: + + $ echo 'let () = A.a (); print_endline (Helper.v ())' > bin/bin.ml + $ dune exec ./bin/bin.exe + lib:helper:IMPL + helper:IMPL + +We can instantiate multiple times, if we give a name to each instantiation, but +the result is wrapped: + + $ echo 'let () = print_endline (Lib1.Lib.v () ^ " " ^ Lib2.Helper.v ())' > bin/bin.ml + $ cat > bin/dune < (executable (name bin) + > (libraries + > (lib impl :as lib1) + > (lib impl :as lib2))) + > EOF + $ dune exec ./bin/bin.exe + lib:helper:IMPL helper:IMPL + + $ cat _build/default/bin/.bin.eobjs/dune__exe.ml-gen + (* generated by dune *) + + (** @canonical Dune__exe.A *) + module A = Dune__exe__A + + (** @canonical Dune__exe.Bin *) + module Bin = Dune__exe__Bin + + (** @canonical Dune__exe.Util *) + module Util = Dune__exe__Util + + module Lib1 = struct + module Helper = Helper(Param)(Impl) [@jane.non_erasable.instances] + module Lib = Lib(Param)(Impl) [@jane.non_erasable.instances] + end + + module Lib2 = struct + module Helper = Helper(Param)(Impl) [@jane.non_erasable.instances] + module Lib = Lib(Param)(Impl) [@jane.non_erasable.instances] + end + +Testing that it also works with another layer of library: + + $ mkdir lib2 + $ echo 'let v2 () = "lib2:" ^ Lib.v () ^ " " ^ Helper.v ()' > lib2/lib2.ml + $ cat > lib2/dune < (library (name lib2) (libraries (lib impl))) + > EOF + + $ echo 'let () = A.a (); print_endline (Lib2.v2 ())' > bin/bin.ml + $ cat > bin/dune < (executable (name bin) (libraries (lib impl) lib2)) + > EOF + + $ dune exec ./bin/bin.exe + lib:helper:IMPL + lib2:lib:helper:IMPL helper:IMPL From c36f7f90aeedd0893a2efd67b741416c09212ec5 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 21 Oct 2025 16:08:38 +0200 Subject: [PATCH 09/26] improve error messages Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 4 +- src/dune_rules/parameterized_rules.ml | 179 +++++++++++++++--- .../oxcaml/install-parameterized.t/.run.t.swn | Bin 12288 -> 0 bytes .../install-parameterized.t/external/lib/dune | 2 +- .../external/lib/lib.ml | 2 +- .../oxcaml/install-parameterized.t/run.t | 4 +- .../oxcaml/instantiate-parameterized.t | 28 +-- 7 files changed, 173 insertions(+), 46 deletions(-) delete mode 100644 test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/.run.t.swn diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index db7bcbdc039..657b5bf928d 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -608,9 +608,9 @@ module Parameterized = struct List.sort arguments ~compare:(fun (param, _) (param', _) -> compare param param') ;; - let instantiate ~loc named_lib args ~parent_parameters = + let instantiate ~loc lib args ~parent_parameters = let open Resolve.O in - let* lib = named_lib + let* lib = lib and* args = make_arguments args in let* lib = apply_arguments ~ignore_extra:false lib args in let+ () = diff --git a/src/dune_rules/parameterized_rules.ml b/src/dune_rules/parameterized_rules.ml index 59b96945c21..c505cf13842 100644 --- a/src/dune_rules/parameterized_rules.ml +++ b/src/dune_rules/parameterized_rules.ml @@ -398,38 +398,125 @@ let gen_rules ~sctx ~dir ~scope rest = type instance = { new_name : Module_name.t ; lib_name : Module_name.t - ; args : (Module_name.t * Module_name.t) list + ; args : (Loc.t * Module_name.t * Module_name.t) list + ; loc : Loc.t } type instances = | Simple of instance - | Wrapped of Module_name.t * instance list + | Wrapped of Loc.t * Module_name.t * instance list + +module Errors = struct + let make_resolve ?loc ?hints paragraphs = + Resolve.fail + (User_error.make + ?loc + ?hints + paragraphs + ~annots:(User_message.Annots.singleton User_message.Annots.needs_stack_trace ())) + ;; + + let make ?loc ?hints paragraphs = Memo.return @@ make_resolve ?loc ?hints paragraphs + + let library_not_found ~loc name = + make ~loc [ Pp.textf "Library parameter %S not found." (Lib_name.to_string name) ] + ;; + + let duplicate_parameters ~loc ~param arg arg' = + make + ~loc + [ Pp.textf + "Duplicate arguments %s and %s for parameter %s." + (Lib_name.to_string (Lib.name arg)) + (Lib_name.to_string (Lib.name arg')) + (Lib_name.to_string (Lib.name param)) + ] + ;; + + let missing_implements ~loc p = + let name = Lib_name.to_string (Lib.name p) in + make ~loc [ Pp.textf "Library %S does not implement a library parameter." name ] + ;; + + let unexpected_argument ?loc param arg = + make + ?loc + [ Pp.textf + "Argument %s implements unexpected parameter %s" + (Lib_name.to_string (Lib.name arg)) + (Lib_name.to_string (Lib.name param)) + ] + ~hints:[ Pp.text "Remove this argument" ] + ;; + + let new_name_already_used ?loc name = + make + ?loc + [ Pp.textf "The instance name %s is already used." (Module_name.to_string name) ] + ;; + + let module_name_already_used ?loc name = + make + ?loc + [ Pp.textf "Module name %s has already been used." (Module_name.to_string name) ] + ;; +end let instances ~sctx ~db (deps : Lib_dep.t list) = let open Resolve.Memo.O in Resolve.Memo.List.concat_map deps ~f:(function | Lib_dep.Direct _ | Lib_dep.Re_export _ | Lib_dep.Select _ -> Resolve.Memo.return [] - | Lib_dep.Instantiate { loc = _; lib; arguments; new_name } -> - let+ entry_names = - let* lib = Resolve.Memo.lift_memo @@ Lib.DB.find db lib in + | Lib_dep.Instantiate { loc; lib = lib_name; arguments; new_name } -> + let* lib = Resolve.Memo.lift_memo @@ Lib.DB.find db lib_name in + let lib = match lib with - | None -> Resolve.Memo.return [] - | Some lib -> Root_module.entry_module_names sctx lib + | None -> Code_error.raise "lib not found" [ "lib", Lib_name.to_dyn lib_name ] + | Some lib -> lib + in + let* expected_params = + let* parameters = Lib.parameters lib in + let+ module_names = + Resolve.Memo.List.filter_map parameters ~f:Lib.main_module_name + in + Module_name.Map.of_list_map_exn module_names ~f:(fun m -> m, []) + in + let+ entry_names = Root_module.entry_module_names sctx lib and+ args = - Resolve.Memo.List.filter_map arguments ~f:(fun (_loc, arg_name) -> - let* arg = Resolve.Memo.lift_memo @@ Lib.DB.find db arg_name in - match arg with - | None -> Resolve.Memo.return None - | Some arg -> - (match Lib.implements arg with - | None -> Resolve.Memo.return None - | Some param -> - let* param = param in - let+ param_name = Lib.main_module_name param - and+ arg_name = Lib.main_module_name arg in - (match param_name, arg_name with - | Some param_name, Some arg_name -> Some (param_name, arg_name) - | _ -> None))) + Resolve.Memo.List.fold_left + arguments + ~init:expected_params + ~f:(fun args (loc, arg_name) -> + let* arg = Resolve.Memo.lift_memo @@ Lib.DB.find db arg_name in + match arg with + | None -> Errors.library_not_found ~loc arg_name + | Some arg -> + (match Lib.implements arg with + | None -> Errors.missing_implements ~loc arg + | Some param -> + let* param = param in + let* param_name = Lib.main_module_name param + and* arg_name = Lib.main_module_name arg in + (match param_name, arg_name with + | Some param_name, Some arg_name -> + (match Module_name.Map.find args param_name with + | Some [] -> + Resolve.Memo.return + @@ Module_name.Map.add_multi args param_name (loc, arg, arg_name) + | None -> Errors.unexpected_argument ~loc arg param + | Some ((_, existing, _) :: _) -> + Errors.duplicate_parameters ~loc ~param existing arg) + | None, None | Some _, None | None, Some _ -> + Errors.missing_implements ~loc arg))) + in + let args = + Module_name.Map.foldi args ~init:[] ~f:(fun param arg_opt acc -> + match arg_opt with + | [] -> acc + | [ (loc, _lib, arg) ] -> (loc, param, arg) :: acc + | (_, arg, _) :: (_, arg', _) :: _ -> + Code_error.raise + "duplicate arguments were already reported" + [ "arg", Lib.to_dyn arg; "arg'", Lib.to_dyn arg' ]) in (match entry_names with | [] -> [] @@ -439,15 +526,55 @@ let instances ~sctx ~db (deps : Lib_dep.t list) = | None -> entry_name | Some new_name -> new_name in - [ Simple { new_name; lib_name = entry_name; args } ] + [ Simple { new_name; lib_name = entry_name; args; loc } ] | _ :: _ :: _ -> let instances = List.map entry_names ~f:(fun name -> - { new_name = name; lib_name = name; args }) + { new_name = name; lib_name = name; args; loc }) in (match new_name with | None -> List.map ~f:(fun i -> Simple i) instances - | Some new_name -> [ Wrapped (new_name, instances) ]))) + | Some new_name -> [ Wrapped (loc, new_name, instances) ]))) +;; + +let check_instance known_names instance = + if Module_name.Set.mem known_names instance.new_name + then Errors.new_name_already_used ~loc:instance.loc instance.new_name + else if Module_name.Set.mem known_names instance.lib_name + then Errors.module_name_already_used ~loc:instance.loc instance.new_name + else + let open Resolve.Memo.O in + let+ () = + Resolve.Memo.List.iter instance.args ~f:(fun (loc, _param_name, arg_name) -> + if Module_name.Set.mem known_names arg_name + then Errors.module_name_already_used ~loc instance.new_name + else Resolve.Memo.return ()) + in + Module_name.Set.add known_names instance.new_name +;; + +let check_instances instances = + let open Resolve.Memo.O in + Resolve.Memo.List.fold_left + instances + ~init:Module_name.Set.empty + ~f:(fun acc -> function + | Simple instance -> check_instance acc instance + | Wrapped (loc, wrapped_name, instances) -> + if Module_name.Set.mem acc wrapped_name + then Errors.new_name_already_used ~loc wrapped_name + else + let+ _sub_definitions : Module_name.Set.t = + Resolve.Memo.List.fold_left instances ~init:acc ~f:check_instance + in + Module_name.Set.add acc wrapped_name) +;; + +let instances ~sctx ~db deps = + let open Resolve.Memo.O in + let* instances = instances ~sctx ~db deps in + let+ _ = check_instances instances in + instances ;; let print_instance b indent instance = @@ -458,7 +585,7 @@ let print_instance b indent instance = (Module_name.to_string instance.new_name) (Module_name.to_string instance.lib_name) (String.concat ~sep:"" - @@ List.map instance.args ~f:(fun (param_name, arg_name) -> + @@ List.map instance.args ~f:(fun (_loc, param_name, arg_name) -> Printf.sprintf "(%s)(%s)" (Module_name.to_string param_name) @@ -469,7 +596,7 @@ let print_instances b instances = List.iter instances ~f:(fun instances -> match instances with | Simple instance -> print_instance b "" instance - | Wrapped (new_name, instances) -> + | Wrapped (_loc, new_name, instances) -> Printf.bprintf b "\nmodule %s = struct" (Module_name.to_string new_name); List.iter instances ~f:(print_instance b " "); Printf.bprintf b "\nend\n") diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/.run.t.swn b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/.run.t.swn deleted file mode 100644 index 11f60cdc7799fbbceb6f04902fcc9fb489406a25..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 12288 zcmeI2&2QX97>6g7koYR!2g>Q~5@au`?Ifj$d{vY{`B1B*(w6o@w_|&fHSyXjdp6xr zHRS?AaO4U{KE#b)K|)BJ_yah>f54$a2#Es{zZu)J*`!Iu5tx;pI3ADRo%eZPTZ%H_ z%$u*Dr+I&t;qwS%f8M&?`(yj3sq2s4!z3?~Sd{9@p`Uu5*XbqM<{FQ^%d_4JFTyEQOd<{MY7r-2N0{r#>V?Tgz!8afU z7r+{L2{_;>@caFU13m}ugB>8i8(<#%g&e;JpMVd*yWl2Jxjzq1fi`e~1MJ5dum-FF zYrq(4paB4&5oom zg-I3wA14f#PSY!^XY~lUd>TSwcj%V=6@cQMW2WJ#wWmk7qd8*O7IMoxiQQhPFW$GB?aCg$FrZ5%@yw(!cq9;f-ukOdDbultF zWfCNr=Z6Xp#kewRr#6M#6Opdg)#;j$S0|0T!xB}XYWFwI__Iw{a*XO1$Vq>0W_L5H zL2ppxZ;MFQPp0-NMuWVNw7PQU{JFI=o!6FqKWJ(nbi-ki#?9{X04n$}l>t^))g-22 zDT-Zvs83m^Co;Nbo@P-!ziFx;^aYhk{l3@X$@7Xlmt&7F*1OpmJDU`Ee<4z<9%|7< qd)Jx}vZG#f)r(_SMaH$Ge0{9E)P*!|bp@(Wcv0&Dqd-U{_SxTRIh3CO diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune index c5d8762a915..5d93ba347c7 100644 --- a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune @@ -2,5 +2,5 @@ (public_name external.lib) (name lib) (libraries - (paramlib impl) + (paramlib impl :as paramlib1) (paramlib impl2 :as paramlib2))) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml index f456c7fd1b9..db15e0126dd 100644 --- a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml @@ -1 +1 @@ -let test () = String.uppercase_ascii (Paramlib.v ^ " " ^ Paramlib2.v) +let test () = String.uppercase_ascii (Paramlib1.v ^ " " ^ Paramlib2.v) diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t index 5c6064d34e8..b577fa2d0a5 100644 --- a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t @@ -48,7 +48,7 @@ and local implementations: > print_endline Paramlib_impl.v ; > print_endline Paramlib_otherext.v ; > print_endline (Lib.test ()) ; - > print_endline (Unwrapped_a.a ^ "," ^ Unwrapped_b.b) ; + > print_endline Unwrap_lib.(Unwrapped_a.a ^ "," ^ Unwrapped_b.b) ; > print_endline (Rewrap.Unwrapped_a.a ^ "," ^ Rewrap.Unwrapped_b.b) ; > print_endline Other_ext.v > EOF @@ -58,7 +58,7 @@ and local implementations: > (external.paramlib external.impl :as paramlib_impl) > (external.paramlib other_ext :as paramlib_otherext) > external.lib ; has instances internally - > (external.unwrapped_lib external.impl) + > (external.unwrapped_lib external.impl :as unwrap_lib) > (external.unwrapped_lib other_ext :as rewrap) > other_ext)) > EOF diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t index 3796de96ea2..65254828631 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t @@ -71,6 +71,7 @@ It's an error for the binary to partially instantiate `lib_ab`: 3 | (libraries (lib_ab b_impl))) ; missing a_impl ^^^^^^ Error: Parameter "project.a" is missing. + -> required by _build/default/bin/bin.exe -> required by _build/install/default/bin/project.bin Hint: Pass an argument implementing project.a to the dependency, or add (parameters project.a) @@ -91,11 +92,11 @@ overlapping modules) > EOF $ dune exec project.bin - File "bin/.bin.eobjs/dune__exe.ml-gen", line 7, characters 0-75: - 7 | module Lib_ab = Lib_ab(A)(A_impl)(B)(B_impl) [@jane.non_erasable.instances] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: Multiple definition of the module name Lib_ab. - Names must be unique in a given structure or signature. + File "bin/dune", line 7, characters 5-11: + 7 | (lib_ab a_impl b_impl))) + ^^^^^^ + Error: The instance name Lib_ab is already used. + -> required by _build/install/default/bin/project.bin [1] We add another way to implement the parameter `b` from the parameter `a`: @@ -126,10 +127,9 @@ dependencies, because its parameter `b` is missing: File "bin/dune", line 6, characters 19-25: 6 | (lib_ab a_impl a_of_b))) ^^^^^^ - Error: Parameter "project.b" is missing. + Error: Duplicate arguments project.a_impl and project.a_of_b for parameter + project.a. -> required by _build/install/default/bin/project.bin - Hint: Pass an argument implementing project.b to the dependency, or add - (parameters project.b) [1] However `lib_ab` can depend on `a_of_b`, such that the parameter `b` will be @@ -189,9 +189,9 @@ It's an error to provide a non-required parameter: File "bin/dune", line 4, characters 15-21: 4 | (lib_apply a_impl b_impl :as lib_ab))) ^^^^^^ - Error: Unexpected argument "project.a_impl" + Error: Argument project.a implements unexpected parameter project.a_impl -> required by _build/install/default/bin/project.bin - Hint: Remove the extra argument + Hint: Remove this argument [1] Given another implementation of a parameter, @@ -216,9 +216,9 @@ which one to use: File "bin/dune", line 4, characters 22-29: 4 | (lib_apply b_impl b_impl2))) ^^^^^^^ - Error: Unexpected argument "project.b_impl2" + Error: Duplicate arguments project.b_impl and project.b_impl2 for parameter + project.b. -> required by _build/install/default/bin/project.bin - Hint: Remove the extra argument [1] Same error if the argument is repeated: @@ -233,9 +233,9 @@ Same error if the argument is repeated: File "bin/dune", line 4, characters 22-28: 4 | (lib_apply b_impl b_impl))) ^^^^^^ - Error: Unexpected argument "project.b_impl" + Error: Duplicate arguments project.b_impl and project.b_impl for parameter + project.b. -> required by _build/install/default/bin/project.bin - Hint: Remove the extra argument [1] We can instantiate the same library multiple times by giving it different names: From e36d4108b4d672f35bcc8821e5b119ac3ec3dc61 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 22 Oct 2025 10:57:46 +0200 Subject: [PATCH 10/26] testing unwrapped libs with instantiated deps Signed-off-by: ArthurW --- src/dune_rules/ml_sources.ml | 1 - src/dune_rules/root_module.ml | 2 +- .../oxcaml/unwrapped-with-instantiate.t | 26 +++++++++++++++++++ 3 files changed, 27 insertions(+), 2 deletions(-) diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index de1eec9aeeb..15a6636af8f 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -403,7 +403,6 @@ let make_lib_modules kind, main_module_name, wrapped in let has_instances = has_instances lib.buildable in - let wrapped = if has_instances then Wrapped.Simple true else wrapped in let open Memo.O in let* sources, modules = let { Buildable.loc = stanza_loc; modules = modules_settings; _ } = lib.buildable in diff --git a/src/dune_rules/root_module.ml b/src/dune_rules/root_module.ml index caf1f05404b..5d0dd2e8804 100644 --- a/src/dune_rules/root_module.ml +++ b/src/dune_rules/root_module.ml @@ -16,5 +16,5 @@ let entries sctx ~requires_compile = Action_builder.List.map requires ~f:(fun lib -> Action_builder.of_memo (entry_module_names sctx lib) >>= Resolve.read) in - Action_builder.return (List.concat l) + Action_builder.return (List.concat l |> List.sort_uniq ~compare:Module_name.compare) ;; diff --git a/test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t b/test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t index 1edd97ccf49..15afaa47680 100644 --- a/test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t +++ b/test/blackbox-tests/test-cases/oxcaml/unwrapped-with-instantiate.t @@ -135,3 +135,29 @@ Testing that it also works with another layer of library: $ dune exec ./bin/bin.exe lib:helper:IMPL lib2:lib:helper:IMPL helper:IMPL + +TODO: An unwrapped library currently has to instantiate the functors manually, +because we don't have a file where to put the instantiations: + + $ mkdir unwrap_lib + $ cat > unwrap_lib/unwrap_a.ml < module Lib = Lib(Param)(Impl) [@jane.non_erasable.instances] + > let a () = "a:" ^ Lib.v () + > EOF + $ echo 'let b () = "b:" ^ Unwrap_a.a ()' > unwrap_lib/unwrap_b.ml + $ cat > unwrap_lib/dune < (library + > (name unwrap_lib) + > (wrapped false) + > (flags "-w" "-53") ; ignore misplaced-attribute warning + > (libraries (lib impl))) + > EOF + + $ echo 'let () = print_endline (Unwrap_a.a () ^ "," ^ Unwrap_b.b ())' > bin/bin.ml + $ cat > bin/dune < (executable (name bin) (libraries unwrap_lib)) + > EOF + + $ dune exec ./bin/bin.exe + a:lib:helper:IMPL,b:a:lib:helper:IMPL + From 564061ae01578061adae75ff167639537da09929 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 24 Oct 2025 10:44:32 +0200 Subject: [PATCH 11/26] simplify has_instances Signed-off-by: ArthurW --- src/dune_rules/compilation_context.ml | 15 ++++------ src/dune_rules/compilation_context.mli | 4 +-- src/dune_rules/lib.ml | 22 ++++---------- src/dune_rules/module_compilation.ml | 17 +++++++---- .../oxcaml/instantiate-parameterized.t | 29 +++++++++++++++++++ 5 files changed, 53 insertions(+), 34 deletions(-) diff --git a/src/dune_rules/compilation_context.ml b/src/dune_rules/compilation_context.ml index d15d1e88d93..18eca83a63a 100644 --- a/src/dune_rules/compilation_context.ml +++ b/src/dune_rules/compilation_context.ml @@ -89,7 +89,7 @@ type t = ; requires_link : Lib.t list Resolve.t Memo.Lazy.t ; implements : Virtual_rules.t ; parameters : Module_name.t list Resolve.Memo.t - ; instances : Parameterized_rules.instances list Resolve.Memo.t + ; instances : Parameterized_rules.instances list Resolve.Memo.t option ; includes : Includes.t ; preprocessing : Pp_spec.t ; opaque : bool @@ -189,11 +189,6 @@ let create | None -> Resolve.Memo.return [] | Some parameters -> parameters_main_modules parameters in - let instances = - match instances with - | None -> Resolve.Memo.return [] - | Some instances -> instances - in let sandbox = Sandbox_config.no_special_requirements in let modes = let default = @@ -252,7 +247,7 @@ let alias_and_root_module_flags = fun base -> Ocaml_flags.append_common base extra ;; -let for_alias_module ~has_instances t alias_module = +let for_alias_module t alias_module = let keep_flags = Modules.With_vlib.is_stdlib_alias (modules t) alias_module in let flags = if keep_flags @@ -265,13 +260,13 @@ let for_alias_module ~has_instances t alias_module = Ocaml_flags.default ~dune_version ~profile) in let flags = - if has_instances - then + match t.instances with + | None -> flags + | Some _ -> (* If the alias file instantiates parameterized libraries, the [misplace-attribute] warning is currently raised on [@jane.non_erasable.instances] *) Ocaml_flags.append_common flags [ "-w"; "-53" ] - else flags in let sandbox = (* If the compiler reads the cmi for module alias even with [-w -49 diff --git a/src/dune_rules/compilation_context.mli b/src/dune_rules/compilation_context.mli index a7c2638219c..4215bd4ca75 100644 --- a/src/dune_rules/compilation_context.mli +++ b/src/dune_rules/compilation_context.mli @@ -43,7 +43,7 @@ val create -> t Memo.t (** Return a compilation context suitable for compiling the alias module. *) -val for_alias_module : has_instances:bool -> t -> Module.t -> t +val for_alias_module : t -> Module.t -> t val super_context : t -> Super_context.t val context : t -> Context.t @@ -91,4 +91,4 @@ val dep_graphs : t -> Dep_graph.t Ml_kind.Dict.t val loc : t -> Loc.t option val set_obj_dir : t -> Path.Build.t Obj_dir.t -> t val set_modes : t -> modes:Lib_mode.Map.Set.t -> t -val instances : t -> Parameterized_rules.instances list Resolve.Memo.t +val instances : t -> Parameterized_rules.instances list Resolve.Memo.t option diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 657b5bf928d..be67715179c 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -283,13 +283,6 @@ module Error = struct ~loc [ Pp.textf "Library %S does not implement a library parameter." name ] ;; - - let too_many_arguments ?loc p = - make_resolve - ?loc - [ Pp.textf "Unexpected argument %S" (Lib_name.to_string (Lib_info.name p)) ] - ~hints:[ Pp.text "Remove the extra argument" ] - ;; end (* Types *) @@ -561,21 +554,18 @@ module Parameterized = struct List.combine parameters t.arguments ;; - let apply_arguments ~ignore_extra t new_arguments = + let apply_arguments t new_arguments = let open Resolve.O in let rec go acc existing' given' = match existing', given' with | (param_intf, Some arg) :: existing, _ -> go ((param_intf, Some arg) :: acc) existing given' - | [], [] -> Resolve.return (List.rev acc) - | [], _ when ignore_extra -> Resolve.return (List.rev acc) - | [], (_, extra) :: _ -> Error.too_many_arguments ~loc:extra.loc extra.arg.info + | [], _ -> Resolve.return (List.rev acc) | ((param_intf, None) as keep) :: existing, (param_intf', arg) :: given -> (match compare param_intf param_intf' with | Eq -> go ((param_intf, Some arg) :: acc) existing given | Lt -> go (keep :: acc) existing given' - | Gt when ignore_extra -> go acc existing' given - | Gt -> Error.too_many_arguments ~loc:arg.loc arg.arg.info) + | Gt -> go acc existing' given) | ((_, None) as keep) :: existing, [] -> go (keep :: acc) existing [] in let* t_arguments = parameterized_arguments t in @@ -612,7 +602,7 @@ module Parameterized = struct let open Resolve.O in let* lib = lib and* args = make_arguments args in - let* lib = apply_arguments ~ignore_extra:false lib args in + let* lib = apply_arguments lib args in let+ () = let* all_args = parameterized_arguments lib in Resolve.List.iter all_args ~f:(function @@ -635,10 +625,10 @@ module Parameterized = struct match opt_arg with | None -> Resolve.return None | Some argument -> - let+ arg = apply_arguments ~ignore_extra:true argument.arg parent_arguments in + let+ arg = apply_arguments argument.arg parent_arguments in Some { argument with arg }) in - apply_arguments ~ignore_extra:true { dep with arguments } parent_arguments + apply_arguments { dep with arguments } parent_arguments ;; let remove_arguments lib = { lib with parameters = Resolve.return []; arguments = [] } diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index 1655e9624c5..481de4496ff 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -512,9 +512,14 @@ module Alias_module = struct end let build_alias_module cctx group = - let* instances = Resolve.Memo.read_memo (Compilation_context.instances cctx) in - let has_instances = instances <> [] in - let alias_file () = + let alias_file = + let+ instances = + Resolve.Memo.read_memo + @@ + match Compilation_context.instances cctx with + | None -> Resolve.Memo.return [] + | Some instances -> instances + in let project = Compilation_context.scope cctx |> Scope.project in let modules = Compilation_context.modules cctx in Alias_module.of_modules project modules group instances |> Alias_module.to_ml @@ -528,10 +533,10 @@ let build_alias_module cctx group = ~loc:Loc.none sctx ~dir - (Action_builder.delayed alias_file + (Action_builder.of_memo alias_file |> Action_builder.write_file_dyn (Path.as_in_build_dir_exn file)) in - let cctx = Compilation_context.for_alias_module ~has_instances cctx alias_module in + let cctx = Compilation_context.for_alias_module cctx alias_module in build_module cctx alias_module ;; @@ -593,7 +598,7 @@ let build_all cctx = then (* XXX it would probably be simpler if the flags were just for this module in the definition of the stanza *) - Compilation_context.for_alias_module ~has_instances:false cctx m + Compilation_context.for_alias_module cctx m else cctx in build_module cctx m)) diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t index 65254828631..8a401e80170 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t @@ -96,6 +96,10 @@ overlapping modules) 7 | (lib_ab a_impl b_impl))) ^^^^^^ Error: The instance name Lib_ab is already used. + -> required by _build/default/bin/.bin.eobjs/dune__exe.ml-gen + -> required by _build/default/bin/.bin.eobjs/byte/dune__exe.cmi + -> required by _build/default/bin/.bin.eobjs/native/dune__exe.cmx + -> required by _build/default/bin/bin.exe -> required by _build/install/default/bin/project.bin [1] @@ -129,7 +133,20 @@ dependencies, because its parameter `b` is missing: ^^^^^^ Error: Duplicate arguments project.a_impl and project.a_of_b for parameter project.a. + -> required by _build/default/bin/.bin.eobjs/dune__exe.ml-gen + -> required by _build/default/bin/.bin.eobjs/byte/dune__exe.cmi + -> required by _build/default/bin/.bin.eobjs/native/dune__exe.cmx + -> required by _build/default/bin/bin.exe + -> required by _build/install/default/bin/project.bin + File "bin/dune", line 6, characters 19-25: + 6 | (lib_ab a_impl a_of_b))) + ^^^^^^ + Error: Parameter "project.b" is missing. + -> required by _build/default/bin/.bin.eobjs/native/dune__exe__Bin.cmx + -> required by _build/default/bin/bin.exe -> required by _build/install/default/bin/project.bin + Hint: Pass an argument implementing project.b to the dependency, or add + (parameters project.b) [1] However `lib_ab` can depend on `a_of_b`, such that the parameter `b` will be @@ -190,6 +207,10 @@ It's an error to provide a non-required parameter: 4 | (lib_apply a_impl b_impl :as lib_ab))) ^^^^^^ Error: Argument project.a implements unexpected parameter project.a_impl + -> required by _build/default/bin/.bin.eobjs/dune__exe.ml-gen + -> required by _build/default/bin/.bin.eobjs/byte/dune__exe.cmi + -> required by _build/default/bin/.bin.eobjs/native/dune__exe.cmx + -> required by _build/default/bin/bin.exe -> required by _build/install/default/bin/project.bin Hint: Remove this argument [1] @@ -218,6 +239,10 @@ which one to use: ^^^^^^^ Error: Duplicate arguments project.b_impl and project.b_impl2 for parameter project.b. + -> required by _build/default/bin/.bin.eobjs/dune__exe.ml-gen + -> required by _build/default/bin/.bin.eobjs/byte/dune__exe.cmi + -> required by _build/default/bin/.bin.eobjs/native/dune__exe.cmx + -> required by _build/default/bin/bin.exe -> required by _build/install/default/bin/project.bin [1] @@ -235,6 +260,10 @@ Same error if the argument is repeated: ^^^^^^ Error: Duplicate arguments project.b_impl and project.b_impl for parameter project.b. + -> required by _build/default/bin/.bin.eobjs/dune__exe.ml-gen + -> required by _build/default/bin/.bin.eobjs/byte/dune__exe.cmi + -> required by _build/default/bin/.bin.eobjs/native/dune__exe.cmx + -> required by _build/default/bin/bin.exe -> required by _build/install/default/bin/project.bin [1] From 56db3331a7e355eb45afedce63f7e731afabdc51 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 24 Oct 2025 11:38:07 +0200 Subject: [PATCH 12/26] cleanup Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 2 +- src/dune_rules/lib_flags.ml | 16 ++++++++-------- src/dune_rules/parameterized_rules.ml | 4 ++-- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index be67715179c..af805da5080 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -644,7 +644,7 @@ module Parameterized = struct | None -> None | Some arg -> Some arg.arg) in - let deps = List.rev_append lib_arguments deps in + let deps = lib_arguments @ deps in let deps = match lib_arguments with | [] -> deps diff --git a/src/dune_rules/lib_flags.ml b/src/dune_rules/lib_flags.ml index c4c3e6a9419..4b4ed3372a7 100644 --- a/src/dune_rules/lib_flags.ml +++ b/src/dune_rules/lib_flags.ml @@ -340,16 +340,16 @@ module Lib_and_module = struct ~kind:(Ocaml (Mode.cm_kind (Link_mode.mode mode)))) :: (match mode with + | Byte | Byte_for_jsoo | Byte_with_stubs_statically_linked_in -> [] | Native -> [ Command.Args.Hidden_deps - (Dep.Set.of_files - [ Obj_dir.Module.o_file_exn - obj_dir - m - ~ext_obj:lib_config.ext_obj - ]) - ] - | Byte | Byte_for_jsoo | Byte_with_stubs_statically_linked_in -> [])) + ([ Obj_dir.Module.o_file_exn + obj_dir + m + ~ext_obj:lib_config.ext_obj + ] + |> Dep.Set.of_files) + ])) |> Action_builder.return) in Command.Args.S l) diff --git a/src/dune_rules/parameterized_rules.ml b/src/dune_rules/parameterized_rules.ml index c505cf13842..2f782e0a7aa 100644 --- a/src/dune_rules/parameterized_rules.ml +++ b/src/dune_rules/parameterized_rules.ml @@ -357,7 +357,7 @@ let external_dep_rules ~sctx ~dir ~scope lib_name = | Local -> Memo.return () | External None -> Code_error.raise "library has no modules" [ "lib", Lib.to_dyn lib ] | External (Some modules) -> - let+ _ = + let+ (_ : Dep_graph.Ml_kind.t) = Dep_rules.rules ~sctx ~sandbox:Sandbox_config.no_special_requirements @@ -573,7 +573,7 @@ let check_instances instances = let instances ~sctx ~db deps = let open Resolve.Memo.O in let* instances = instances ~sctx ~db deps in - let+ _ = check_instances instances in + let+ (_ : Module_name.Set.t) = check_instances instances in instances ;; From d600f9fe55dd23f70ab0ac9b8f19d7597ad20cbd Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 24 Oct 2025 12:23:50 +0200 Subject: [PATCH 13/26] rename parameterized to parameterised Signed-off-by: ArthurW --- doc/reference/dune/library.rst | 2 +- doc/reference/dune/library_parameter.rst | 2 +- src/dune_lang/lib_dep.ml | 2 +- src/dune_rules/compilation_context.ml | 4 +- src/dune_rules/compilation_context.mli | 4 +- src/dune_rules/exe_rules.ml | 2 +- src/dune_rules/gen_rules.ml | 6 +- src/dune_rules/lib.ml | 56 +++++++++---------- src/dune_rules/lib.mli | 8 +-- src/dune_rules/lib_flags.ml | 2 +- src/dune_rules/lib_rules.ml | 2 +- src/dune_rules/module_compilation.ml | 4 +- ...eterized_name.ml => parameterised_name.ml} | 0 ...erized_name.mli => parameterised_name.mli} | 0 ...erized_rules.ml => parameterised_rules.ml} | 26 ++++----- ...ized_rules.mli => parameterised_rules.mli} | 0 .../test-cases/oxcaml/implements-parameter.t | 2 +- .../external/dune-project | 0 .../external/impl/dune | 0 .../external/impl/impl.ml | 0 .../external/impl2/dune | 0 .../external/impl2/impl2.ml | 0 .../external/lib/dune | 0 .../external/lib/lib.ml | 0 .../external/param/dune | 0 .../external/param/param.mli | 0 .../external/paramlib/dune | 0 .../external/paramlib/helper.ml | 0 .../external/paramlib/paramlib.ml | 0 .../external/unwrapped_lib/dune | 0 .../external/unwrapped_lib/unwrapped_a.ml | 0 .../external/unwrapped_lib/unwrapped_b.ml | 0 .../run.t | 4 +- .../oxcaml/instantiate-exponential.t | 12 ++-- ...eterized.t => instantiate-parameterised.t} | 4 +- .../oxcaml/library-field-parameters.t | 8 +-- .../test-cases/oxcaml/parameter-deps.t | 2 +- .../oxcaml/unwrapped-with-instantiate.t | 4 +- 38 files changed, 78 insertions(+), 78 deletions(-) rename src/dune_rules/{parameterized_name.ml => parameterised_name.ml} (100%) rename src/dune_rules/{parameterized_name.mli => parameterised_name.mli} (100%) rename src/dune_rules/{parameterized_rules.ml => parameterised_rules.ml} (96%) rename src/dune_rules/{parameterized_rules.mli => parameterised_rules.mli} (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/dune-project (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/impl/dune (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/impl/impl.ml (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/impl2/dune (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/impl2/impl2.ml (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/lib/dune (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/lib/lib.ml (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/param/dune (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/param/param.mli (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/paramlib/dune (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/paramlib/helper.ml (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/paramlib/paramlib.ml (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/unwrapped_lib/dune (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/unwrapped_lib/unwrapped_a.ml (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/external/unwrapped_lib/unwrapped_b.ml (100%) rename test/blackbox-tests/test-cases/oxcaml/{install-parameterized.t => install-parameterised.t}/run.t (94%) rename test/blackbox-tests/test-cases/oxcaml/{instantiate-parameterized.t => instantiate-parameterised.t} (99%) diff --git a/doc/reference/dune/library.rst b/doc/reference/dune/library.rst index 9f1530abb9c..d4148c9c7ff 100644 --- a/doc/reference/dune/library.rst +++ b/doc/reference/dune/library.rst @@ -222,7 +222,7 @@ order to declare a multi-directory library, you need to use the List the library parameters used by the library and its dependencies. This feature is experimental and requires the compiler you are using to - support parameterized libraries. + support parameterised libraries. See :doc:`/reference/dune/library_parameter`. .. describe:: (js_of_ocaml ...) diff --git a/doc/reference/dune/library_parameter.rst b/doc/reference/dune/library_parameter.rst index 04af6f2fb0f..c1cba410cd5 100644 --- a/doc/reference/dune/library_parameter.rst +++ b/doc/reference/dune/library_parameter.rst @@ -4,7 +4,7 @@ library_parameter .. warning:: This feature is experimental and requires the compiler you are using to - support parameterized libraries. + support parameterised libraries. The ``library_parameter`` stanza describes a parameter interface defined in a single ``.mli`` file. To enable this feature, you need to add ``(using oxcaml 0.1)`` :doc:`extension diff --git a/src/dune_lang/lib_dep.ml b/src/dune_lang/lib_dep.ml index 8489097cb1a..7961b337352 100644 --- a/src/dune_lang/lib_dep.ml +++ b/src/dune_lang/lib_dep.ml @@ -229,7 +229,7 @@ module L = struct User_error.raise ~loc [ Pp.textf - "parameterized library %S is present in multiple forms" + "parameterised library %S is present in multiple forms" (Lib_name.to_string name) ]) in diff --git a/src/dune_rules/compilation_context.ml b/src/dune_rules/compilation_context.ml index 18eca83a63a..94f468d3cde 100644 --- a/src/dune_rules/compilation_context.ml +++ b/src/dune_rules/compilation_context.ml @@ -89,7 +89,7 @@ type t = ; requires_link : Lib.t list Resolve.t Memo.Lazy.t ; implements : Virtual_rules.t ; parameters : Module_name.t list Resolve.Memo.t - ; instances : Parameterized_rules.instances list Resolve.Memo.t option + ; instances : Parameterised_rules.instances list Resolve.Memo.t option ; includes : Includes.t ; preprocessing : Pp_spec.t ; opaque : bool @@ -263,7 +263,7 @@ let for_alias_module t alias_module = match t.instances with | None -> flags | Some _ -> - (* If the alias file instantiates parameterized libraries, + (* If the alias file instantiates parameterised libraries, the [misplace-attribute] warning is currently raised on [@jane.non_erasable.instances] *) Ocaml_flags.append_common flags [ "-w"; "-53" ] diff --git a/src/dune_rules/compilation_context.mli b/src/dune_rules/compilation_context.mli index 4215bd4ca75..c9512d40bb2 100644 --- a/src/dune_rules/compilation_context.mli +++ b/src/dune_rules/compilation_context.mli @@ -38,7 +38,7 @@ val create -> ?modes:Mode_conf.Set.Details.t Lib_mode.Map.t -> ?bin_annot:bool -> ?loc:Loc.t - -> ?instances:Parameterized_rules.instances list Resolve.Memo.t + -> ?instances:Parameterised_rules.instances list Resolve.Memo.t -> unit -> t Memo.t @@ -91,4 +91,4 @@ val dep_graphs : t -> Dep_graph.t Ml_kind.Dict.t val loc : t -> Loc.t option val set_obj_dir : t -> Path.Build.t Obj_dir.t -> t val set_modes : t -> modes:Lib_mode.Map.Set.t -> t -val instances : t -> Parameterized_rules.instances list Resolve.Memo.t option +val instances : t -> Parameterised_rules.instances list Resolve.Memo.t option diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml index 3b5dbc5b14f..b4fe525aeed 100644 --- a/src/dune_rules/exe_rules.ml +++ b/src/dune_rules/exe_rules.ml @@ -185,7 +185,7 @@ let executables_rules let requires_compile = Lib.Compile.direct_requires compile_info in let requires_link = Lib.Compile.requires_link compile_info in let instances = - Parameterized_rules.instances ~sctx ~db:(Scope.libs scope) exes.buildable.libraries + Parameterised_rules.instances ~sctx ~db:(Scope.libs scope) exes.buildable.libraries in let js_of_ocaml = Js_of_ocaml.Mode.Pair.mapi js_of_ocaml ~f:(fun mode x -> diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index cc86e7c114c..78a2bfbc1df 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -523,7 +523,7 @@ let gen_rules_regular_directory (sctx : Super_context.t Memo.t) ~src_dir ~compon ; ".ppx" ; ".dune" ; ".topmod" - ; ".parameterized" + ; ".parameterised" ] in Filename.Set.union automatic toplevel @@ -612,10 +612,10 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t = ~dir (Subdir_set.of_set (Filename.Set.of_list [ "cc_vendor" ])) (fun () -> Configurator_rules.gen_rules ctx) - | ".parameterized" :: rest -> + | ".parameterised" :: rest -> let* sctx = sctx and* scope = Scope.DB.find_by_dir dir in - Parameterized_rules.gen_rules ~sctx ~scope ~dir rest + Parameterised_rules.gen_rules ~sctx ~scope ~dir rest | _ -> gen_rules_regular_directory sctx ~src_dir ~components ~dir ;; diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index af805da5080..757340cd842 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -517,7 +517,7 @@ let resolve_main_module_name t = let main_module_name t = Memo.return (resolve_main_module_name t) -module Parameterized = struct +module Parameterised = struct type nonrec argument = argument = { arg : t ; param_name : Module_name.t @@ -526,13 +526,13 @@ module Parameterized = struct } type status = - | Not_parameterized + | Not_parameterised | Partial | Complete let status t = if List.for_all t.arguments ~f:Option.is_none - then Not_parameterized + then Not_parameterised else ( let rec check_instantiate lib = List.for_all lib.arguments ~f:(function @@ -548,7 +548,7 @@ module Parameterized = struct | Some { arg; _ } -> arg) ;; - let parameterized_arguments t = + let parameterised_arguments t = let open Resolve.O in let+ parameters = t.parameters in List.combine parameters t.arguments @@ -568,7 +568,7 @@ module Parameterized = struct | Gt -> go acc existing' given) | ((_, None) as keep) :: existing, [] -> go (keep :: acc) existing [] in - let* t_arguments = parameterized_arguments t in + let* t_arguments = parameterised_arguments t in let+ arguments = go [] t_arguments new_arguments in let arguments = List.map ~f:snd arguments in { t with arguments } @@ -604,7 +604,7 @@ module Parameterized = struct and* args = make_arguments args in let* lib = apply_arguments lib args in let+ () = - let* all_args = parameterized_arguments lib in + let* all_args = parameterised_arguments lib in Resolve.List.iter all_args ~f:(function | param, None when not (List.exists parent_parameters ~f:(equal param)) -> Error.missing_parameter ~loc param.info @@ -615,7 +615,7 @@ module Parameterized = struct let complement_arguments ~parent dep = let open Resolve.O in - let* parent_arguments = parameterized_arguments parent in + let* parent_arguments = parameterised_arguments parent in let parent_arguments = List.filter_map parent_arguments ~f:(fun (param, opt_arg) -> Option.map opt_arg ~f:(fun arg -> param, arg)) @@ -653,23 +653,23 @@ module Parameterized = struct Resolve.return deps ;; - let parameterized_name t = - let rec parameterized_name t = - let args = arguments t |> List.map ~f:parameterized_name in - { Parameterized_name.name = Lib_name.to_string (name t); args } + let parameterised_name t = + let rec parameterised_name t = + let args = arguments t |> List.map ~f:parameterised_name in + { Parameterised_name.name = Lib_name.to_string (name t); args } in - Parameterized_name.to_string (parameterized_name t) + Parameterised_name.to_string (parameterised_name t) ;; let info ~build_dir ~ext_lib t = match status t with - | Not_parameterized | Partial -> None + | Not_parameterised | Partial -> None | Complete -> - let parameterized_dir = Path.Build.(relative build_dir ".parameterized") in - let parameterized_dir = - Path.Build.relative parameterized_dir (Lib_name.to_string (name t)) + let parameterised_dir = Path.Build.(relative build_dir ".parameterised") in + let parameterised_dir = + Path.Build.relative parameterised_dir (Lib_name.to_string (name t)) in - let dir = Path.Build.relative parameterized_dir (parameterized_name t) in + let dir = Path.Build.relative parameterised_dir (parameterised_name t) in Some (Lib_info.for_instance ~dir ~ext_lib t.info) ;; @@ -692,7 +692,7 @@ module Parameterized = struct let+ name = resolve_main_module_name t and+ args = applied_modules t in match name with - | Some name -> { Parameterized_name.name = Module_name.to_string name; args } + | Some name -> { Parameterised_name.name = Module_name.to_string name; args } | None -> Code_error.raise "library missing main module name" [ "lib", to_dyn t ] ;; end @@ -1036,7 +1036,7 @@ end = struct then R.return () else let* () = R.set (res, Set.add visited t) in - let* deps = R.lift (Resolve.Memo.lift (Parameterized.requires t)) in + let* deps = R.lift (Resolve.Memo.lift (Parameterised.requires t)) in let* () = many deps in R.modify (fun (res, visited) -> t :: res, visited) and many deps = R.List.iter deps ~f:loop in @@ -1679,22 +1679,22 @@ end = struct let resolve_complex_deps db deps ~private_deps ~parameters = let open Memo.O in - let resolve_parameterized_dep (loc, lib) ~arguments = + let resolve_parameterised_dep (loc, lib) ~arguments = resolve_dep db (loc, lib) ~private_deps >>| function | None -> None | Some dep -> - Some (Parameterized.instantiate ~loc dep arguments ~parent_parameters:parameters) + Some (Parameterised.instantiate ~loc dep arguments ~parent_parameters:parameters) in Memo.List.fold_left ~init:Resolved.Builder.empty deps ~f:(fun acc (dep : Lib_dep.t) -> match dep with | Re_export lib -> - resolve_parameterized_dep lib ~arguments:[] + resolve_parameterised_dep lib ~arguments:[] >>| (function | None -> acc | Some lib -> Resolved.Builder.add_re_exports acc lib) | Direct lib -> - resolve_parameterized_dep lib ~arguments:[] + resolve_parameterised_dep lib ~arguments:[] >>| (function | None -> acc | Some lib -> Resolved.Builder.add_resolved acc lib) @@ -1704,14 +1704,14 @@ end = struct | Instantiate { loc; lib; arguments; new_name = _ } -> let* arguments = Memo.List.filter_map arguments ~f:(fun (loc, dep) -> - resolve_parameterized_dep (loc, dep) ~arguments:[] + resolve_parameterised_dep (loc, dep) ~arguments:[] >>| Option.map ~f:(fun dep -> loc, dep)) in let acc = List.fold_left arguments ~init:acc ~f:(fun acc (_loc, dep) -> Resolved.Builder.add_resolved acc dep) in - resolve_parameterized_dep (loc, lib) ~arguments + resolve_parameterised_dep (loc, lib) ~arguments >>| (function | None -> acc | Some lib -> Resolved.Builder.add_resolved acc lib)) @@ -2024,16 +2024,16 @@ end = struct in let* new_stack = R.lift (Dep_stack.push stack ~implements_via lib) in let* (deps : lib list) = - R.lift (Resolve.Memo.lift (Parameterized.requires lib)) + R.lift (Resolve.Memo.lift (Parameterised.requires lib)) in let* unimplemented' = R.lift (Vlib.Unimplemented.add state.unimplemented lib) in let* () = R.modify (fun state -> { state with unimplemented = unimplemented' }) in let* () = R.List.iter deps ~f:(fun l -> visit t (None, l) ~stack:new_stack) in - (match Parameterized.status lib with + (match Parameterised.status lib with | Partial -> R.return () - | Not_parameterized | Complete -> + | Not_parameterised | Complete -> R.modify (fun state -> { state with result = (lib, stack) :: state.result }))) ;; end diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index 4f8d9bd5596..4ab9d6e8be4 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -14,9 +14,9 @@ val name : t -> Lib_name.t val implements : t -> t Resolve.Memo.t option val parameters : t -> t list Resolve.Memo.t -module Parameterized : sig +module Parameterised : sig type status = - | Not_parameterized + | Not_parameterised | Partial | Complete @@ -30,8 +30,8 @@ module Parameterized : sig } val arguments : t -> t list - val applied_modules : t -> Parameterized_name.t list Resolve.t - val applied_name : t -> Parameterized_name.t Resolve.t + val applied_modules : t -> Parameterised_name.t list Resolve.t + val applied_name : t -> Parameterised_name.t Resolve.t val requires : t -> t list Resolve.t val for_instance : build_dir:Path.Build.t -> ext_lib:string -> t -> t diff --git a/src/dune_rules/lib_flags.ml b/src/dune_rules/lib_flags.ml index 4b4ed3372a7..49364b6a52e 100644 --- a/src/dune_rules/lib_flags.ml +++ b/src/dune_rules/lib_flags.ml @@ -321,7 +321,7 @@ module Lib_and_module = struct Action_builder.List.map ts ~f:(function | Lib t -> let t = - Lib.Parameterized.for_instance ~build_dir ~ext_lib:lib_config.ext_lib t + Lib.Parameterised.for_instance ~build_dir ~ext_lib:lib_config.ext_lib t in let+ { Link_params.hidden_deps; include_dirs; deps } = Action_builder.of_memo (Link_params.get sctx t mode lib_config) diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index 647592c235a..6bf7d36d79b 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -513,7 +513,7 @@ let cctx let requires_compile = Lib.Compile.direct_requires compile_info in let requires_link = Lib.Compile.requires_link compile_info in let instances = - Parameterized_rules.instances ~sctx ~db:(Scope.libs scope) lib.buildable.libraries + Parameterised_rules.instances ~sctx ~db:(Scope.libs scope) lib.buildable.libraries in let* modes = let+ ocaml = diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index 481de4496ff..f59df0fb085 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -465,7 +465,7 @@ module Alias_module = struct type t = { aliases : alias list ; shadowed : Module_name.t list - ; instances : Parameterized_rules.instances list + ; instances : Parameterised_rules.instances list } let to_ml { aliases; shadowed; instances } = @@ -486,7 +486,7 @@ module Alias_module = struct b "\nmodule %s = struct end\n[@@deprecated \"this module is shadowed\"]\n" (Module_name.to_string shadowed)); - Parameterized_rules.print_instances b instances; + Parameterised_rules.print_instances b instances; Buffer.contents b ;; diff --git a/src/dune_rules/parameterized_name.ml b/src/dune_rules/parameterised_name.ml similarity index 100% rename from src/dune_rules/parameterized_name.ml rename to src/dune_rules/parameterised_name.ml diff --git a/src/dune_rules/parameterized_name.mli b/src/dune_rules/parameterised_name.mli similarity index 100% rename from src/dune_rules/parameterized_name.mli rename to src/dune_rules/parameterised_name.mli diff --git a/src/dune_rules/parameterized_rules.ml b/src/dune_rules/parameterised_rules.ml similarity index 96% rename from src/dune_rules/parameterized_rules.ml rename to src/dune_rules/parameterised_rules.ml index 2f782e0a7aa..f6435bcba6f 100644 --- a/src/dune_rules/parameterized_rules.ml +++ b/src/dune_rules/parameterised_rules.ml @@ -12,8 +12,8 @@ let obj_file ~obj_dir ~kind ?ext unique_name = let get_cm ~kind lib = let open Resolve.O in - let+ name = Lib.Parameterized.applied_name lib in - let unique_name = Parameterized_name.to_module_name name in + let+ name = Lib.Parameterised.applied_name lib in + let unique_name = Parameterised_name.to_module_name name in let obj_dir = Lib_info.obj_dir (Lib.info lib) in obj_file ~obj_dir ~kind unique_name ;; @@ -153,7 +153,7 @@ let lib_hidden_deps ~sctx ~kind lib requires = match Lib.compare lib dep with | Eq -> Memo.return [] | Lt | Gt -> - (match Lib.Parameterized.status dep with + (match Lib.Parameterised.status dep with | Complete -> let+ cm = Resolve.read_memo (get_cm ~kind dep) in [ cm ] @@ -161,7 +161,7 @@ let lib_hidden_deps ~sctx ~kind lib requires = Code_error.raise "unexpected partial application" [ "lib", Lib.to_dyn lib; "dep", Lib.to_dyn dep ] - | Not_parameterized -> + | Not_parameterised -> let lib = dep in let lib_info = Lib.info dep in let obj_dir = Lib_info.obj_dir lib_info in @@ -188,13 +188,13 @@ let lib_hidden_deps ~sctx ~kind lib requires = let apply_module_name module_ args = let name = Module_name.Unique.to_string (Module.obj_name module_) in - Parameterized_name.to_module_name { name; args } + Parameterised_name.to_module_name { name; args } ;; let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~lib modules = let kind = Lib_mode.Cm_kind.Ocaml (Mode.cm_kind mode) in let ext = Lib_mode.Cm_kind.ext kind in - let cm_args = Lib.Parameterized.arguments lib |> Resolve.List.map ~f:(get_cm ~kind) in + let cm_args = Lib.Parameterised.arguments lib |> Resolve.List.map ~f:(get_cm ~kind) in let* { Lib_config.ext_obj; _ } = let+ ocaml = Super_context.context sctx |> Context.ocaml in ocaml.lib_config @@ -206,7 +206,7 @@ let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~li If we are instantiating a library, then the existence of these module names has already been checked and the resolve can't fail. *) - Resolve.read_memo @@ Lib.Parameterized.applied_modules lib + Resolve.read_memo @@ Lib.Parameterised.applied_modules lib in Memo.List.fold_left modules ~init:Module_name.Map.empty ~f:(fun acc module_ -> let instance = @@ -293,7 +293,7 @@ let instantiate ~sctx lib = match Lib_info.modules lib_info with | External None -> Code_error.raise "library has no modules" [ "lib", Lib.to_dyn lib ] | External (Some modules) -> - let dir = Path.Build.relative build_dir ".parameterized" in + let dir = Path.Build.relative build_dir ".parameterised" in let dir = Path.Build.relative dir (Lib_name.to_string (Lib.name lib)) in Memo.return (obj_dir_for_dep_rules dir, modules) | Local -> @@ -307,9 +307,9 @@ let instantiate ~sctx lib = let* requires = Lib.closure ~linking:true [ lib ] |> Resolve.Memo.map - ~f:(List.map ~f:(Lib.Parameterized.for_instance ~build_dir ~ext_lib)) + ~f:(List.map ~f:(Lib.Parameterised.for_instance ~build_dir ~ext_lib)) in - let lib = Lib.Parameterized.for_instance ~build_dir ~ext_lib lib in + let lib = Lib.Parameterised.for_instance ~build_dir ~ext_lib lib in let obj_dir = Lib_info.obj_dir (Lib.info lib) |> Obj_dir.as_local_exn in let top_sorted_modules = Dep_graph.top_closed_implementations dep_graph impl_only in iter_modes_concurrently ~f:(fun mode -> @@ -329,7 +329,7 @@ let instantiate ~sctx lib = let resolve_instantiation scope str = let db = Scope.libs scope in - let rec go { Parameterized_name.name; args } = + let rec go { Parameterised_name.name; args } = let name = Lib_name.of_string name in let+ lib = Lib.DB.find db name and+ args = Memo.List.map ~f:go args in @@ -337,13 +337,13 @@ let resolve_instantiation scope str = | None -> Code_error.raise "library not found" [] | Some lib -> let args = List.map args ~f:(fun arg -> Loc.none, arg) in - Lib.Parameterized.instantiate + Lib.Parameterised.instantiate ~loc:Loc.none (Resolve.return lib) args ~parent_parameters:[] in - go (Parameterized_name.of_string str) |> Resolve.Memo.read_memo + go (Parameterised_name.of_string str) |> Resolve.Memo.read_memo ;; let external_dep_rules ~sctx ~dir ~scope lib_name = diff --git a/src/dune_rules/parameterized_rules.mli b/src/dune_rules/parameterised_rules.mli similarity index 100% rename from src/dune_rules/parameterized_rules.mli rename to src/dune_rules/parameterised_rules.mli diff --git a/test/blackbox-tests/test-cases/oxcaml/implements-parameter.t b/test/blackbox-tests/test-cases/oxcaml/implements-parameter.t index 318100736f0..38eac4ff6cc 100644 --- a/test/blackbox-tests/test-cases/oxcaml/implements-parameter.t +++ b/test/blackbox-tests/test-cases/oxcaml/implements-parameter.t @@ -1,5 +1,5 @@ This test ensures the `implements` field is working in the context of -parameterized libraries. +parameterised libraries. $ . ./helpers.sh diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/dune-project b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/dune-project similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/dune-project rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/dune-project diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl/dune similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/dune rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl/dune diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/impl.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl/impl.ml similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl/impl.ml rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl/impl.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl2/dune similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/dune rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl2/dune diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/impl2.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl2/impl2.ml similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/impl2/impl2.ml rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/impl2/impl2.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/lib/dune similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/dune rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/lib/dune diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/lib/lib.ml similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/lib/lib.ml rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/lib/lib.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/param/dune similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/dune rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/param/dune diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/param.mli b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/param/param.mli similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/param/param.mli rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/param/param.mli diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/paramlib/dune similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/dune rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/paramlib/dune diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/helper.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/paramlib/helper.ml similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/helper.ml rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/paramlib/helper.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/paramlib.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/paramlib/paramlib.ml similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/paramlib/paramlib.ml rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/paramlib/paramlib.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/dune b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/unwrapped_lib/dune similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/dune rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/unwrapped_lib/dune diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_a.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/unwrapped_lib/unwrapped_a.ml similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_a.ml rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/unwrapped_lib/unwrapped_a.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_b.ml b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/unwrapped_lib/unwrapped_b.ml similarity index 100% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/external/unwrapped_lib/unwrapped_b.ml rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/external/unwrapped_lib/unwrapped_b.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/run.t similarity index 94% rename from test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t rename to test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/run.t index b577fa2d0a5..54cdab3e159 100644 --- a/test/blackbox-tests/test-cases/oxcaml/install-parameterized.t/run.t +++ b/test/blackbox-tests/test-cases/oxcaml/install-parameterised.t/run.t @@ -1,4 +1,4 @@ -Test that an external definition of parameters and parameterized libraries can be used. +Test that an external definition of parameters and parameterised libraries can be used. First we "install" the external library: @@ -17,7 +17,7 @@ Then we test the installation: > (using oxcaml 0.1) > EOF -We test that a library can be parameterized by an external `library_parameter` +We test that a library can be parameterised by an external `library_parameter` definition, and can implement an external parameter too: $ mkdir other_impl diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t index 3779fecbda3..9cb85c45b21 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-exponential.t @@ -1,4 +1,4 @@ -The parameterized libraries can themselves implement a parameter, leading to +The parameterised libraries can themselves implement a parameter, leading to this exponential sequence of instantiations: $ cat >dune-project < bin.ml -Each implementation of `x` is itself parameterized by `x`, with a dependency on +Each implementation of `x` is itself parameterised by `x`, with a dependency on the previous implementation with `(lib lib)` which causes this exponential doubling: @@ -52,9 +52,9 @@ instantiated library names. For dune folders, the number of exclamation points indicates the level of application nesting, i.e. `f!g!!x = f(g(x))` and `f!g!x = f(g)(x)`. -The instantiated libraries are collected in .parameterized: +The instantiated libraries are collected in .parameterised: - $ ls _build/default/.parameterized + $ ls _build/default/.parameterised f g h @@ -63,7 +63,7 @@ The instantiated libraries are collected in .parameterized: With each lib folder containing the list of its instances: - $ ls _build/default/.parameterized/g + $ ls _build/default/.parameterised/g g!g!!h!!!i!!!!x_impl g!g!!h!!!x_impl g!g!!i!!!x_impl @@ -75,7 +75,7 @@ With each lib folder containing the list of its instances: For modules instantiated by the compiler, a dash is used: - $ ls _build/default/.parameterized/f/f!f!!g!!!h!!!!i!!!!!x_impl/.instance.objs/native + $ ls _build/default/.parameterised/f/f!f!!g!!!h!!!!i!!!!!x_impl/.instance.objs/native f-F--G---H----I-----X_impl.cmx f-F--G---H----I-----X_impl.o f__f__-F--G---H----I-----X_impl.cmx diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t similarity index 99% rename from test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t rename to test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t index 8a401e80170..1637c97f496 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterized.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t @@ -1,4 +1,4 @@ -Testing the instantiation of parameterized libraries. This feature requires oxcaml: +Testing the instantiation of parameterised libraries. This feature requires oxcaml: $ cat >> dune-project < (lang dune 3.20) @@ -35,7 +35,7 @@ And two implementations, one with a singleton module and the other with more: > (library (public_name project.b_impl) (name b_impl) (implements b)) > EOF -And a parameterized library: +And a parameterised library: $ mkdir lib_ab $ echo 'let ab = A.a ^ B.b' > lib_ab/lib_ab.ml diff --git a/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t b/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t index e35ea56a575..6175a5fe6ae 100644 --- a/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t +++ b/test/blackbox-tests/test-cases/oxcaml/library-field-parameters.t @@ -134,7 +134,7 @@ which lists the parameters on the following indented lines: The output of `ocamlobjinfo` is not exactly 1:1 with the flags given to the compiler. It only lists the parameters that are actually used (`A` is not used -by `Lib`), but also the parameterized modules that are depended upon, +by `Lib`), but also the parameterised modules that are depended upon, `Lib_util` and `Lib__`: $ ocamlobjinfo _build/default/lib/.lib.objs/native/lib.cmx | runtime_parameters @@ -197,7 +197,7 @@ attempt to build: $ dune build We check that the opam installation will preserve the parameters metadata, both -at the level of the library `project.lib` and for each of its parameterized +at the level of the library `project.lib` and for each of its parameterised modules: $ dune build @install @@ -324,7 +324,7 @@ It's not possible to use the `parameters` fields in other stanzas than Error: Unknown field "parameters" [1] -It's incorrect to depend on a parameterized library without providing the +It's incorrect to depend on a parameterised library without providing the required parameters. $ cat > bin/dune < lib2/dune < (library (name lib2) (parameters a b) (libraries lib)) diff --git a/test/blackbox-tests/test-cases/oxcaml/parameter-deps.t b/test/blackbox-tests/test-cases/oxcaml/parameter-deps.t index 5878ea4d455..941bdfcee15 100644 --- a/test/blackbox-tests/test-cases/oxcaml/parameter-deps.t +++ b/test/blackbox-tests/test-cases/oxcaml/parameter-deps.t @@ -38,7 +38,7 @@ We ensure it built the parameter. $ ocamlobjinfo "$(build_target_cmi 'param_intf')" | grep "Is parameter" Is parameter: YES -A library parameterized by this parameter has transitive access to the `signature` +A library parameterised by this parameter has transitive access to the `signature` library by default: $ make_dir_with_dune "mylib" < dune-project < (lang dune 3.20) @@ -46,7 +46,7 @@ exactly implement the parameter signature (a single mli): > (library (name impl) (implements param)) > EOF -A parameterized library: +A parameterised library: $ mkdir lib $ echo 'let v () = "helper:" ^ String.uppercase_ascii Param.v' > lib/helper.ml From 3a8e93e38ccaf8ac195e6092fddd5e3b4134835d Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 27 Oct 2025 13:01:27 +0100 Subject: [PATCH 14/26] parameterised dir name Signed-off-by: ArthurW --- src/dune_lang/oxcaml.ml | 2 ++ src/dune_lang/oxcaml.mli | 1 + src/dune_rules/gen_rules.ml | 5 +++-- src/dune_rules/lib.ml | 12 ++++++++---- src/dune_rules/lib.mli | 1 + src/dune_rules/parameterised_rules.ml | 3 +-- 6 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/dune_lang/oxcaml.ml b/src/dune_lang/oxcaml.ml index cb57dd8dcf8..22ae2457d06 100644 --- a/src/dune_lang/oxcaml.ml +++ b/src/dune_lang/oxcaml.ml @@ -7,3 +7,5 @@ let syntax = ~experimental:true [ (0, 1), `Since (3, 20) ] ;; + +let parameterised_dir = ".parameterised" diff --git a/src/dune_lang/oxcaml.mli b/src/dune_lang/oxcaml.mli index a02b8300f7b..fdab3917598 100644 --- a/src/dune_lang/oxcaml.mli +++ b/src/dune_lang/oxcaml.mli @@ -1,3 +1,4 @@ open Import val syntax : Syntax.t +val parameterised_dir : string diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index 78a2bfbc1df..82c716bc28f 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -523,7 +523,7 @@ let gen_rules_regular_directory (sctx : Super_context.t Memo.t) ~src_dir ~compon ; ".ppx" ; ".dune" ; ".topmod" - ; ".parameterised" + ; Dune_lang.Oxcaml.parameterised_dir ] in Filename.Set.union automatic toplevel @@ -612,7 +612,8 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t = ~dir (Subdir_set.of_set (Filename.Set.of_list [ "cc_vendor" ])) (fun () -> Configurator_rules.gen_rules ctx) - | ".parameterised" :: rest -> + | parameterised_dir :: rest + when String.equal parameterised_dir Dune_lang.Oxcaml.parameterised_dir -> let* sctx = sctx and* scope = Scope.DB.find_by_dir dir in Parameterised_rules.gen_rules ~sctx ~scope ~dir rest diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 757340cd842..49b240b6914 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -661,14 +661,18 @@ module Parameterised = struct Parameterised_name.to_string (parameterised_name t) ;; + let dir ~build_dir t = + let parameterised_dir = + Path.Build.(relative build_dir Dune_lang.Oxcaml.parameterised_dir) + in + Path.Build.relative parameterised_dir (Lib_name.to_string (name t)) + ;; + let info ~build_dir ~ext_lib t = match status t with | Not_parameterised | Partial -> None | Complete -> - let parameterised_dir = Path.Build.(relative build_dir ".parameterised") in - let parameterised_dir = - Path.Build.relative parameterised_dir (Lib_name.to_string (name t)) - in + let parameterised_dir = dir ~build_dir t in let dir = Path.Build.relative parameterised_dir (parameterised_name t) in Some (Lib_info.for_instance ~dir ~ext_lib t.info) ;; diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index 4ab9d6e8be4..b6e6ad513f8 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -34,6 +34,7 @@ module Parameterised : sig val applied_name : t -> Parameterised_name.t Resolve.t val requires : t -> t list Resolve.t val for_instance : build_dir:Path.Build.t -> ext_lib:string -> t -> t + val dir : build_dir:Path.Build.t -> t -> Path.Build.t val instantiate : loc:Loc.t diff --git a/src/dune_rules/parameterised_rules.ml b/src/dune_rules/parameterised_rules.ml index f6435bcba6f..539f8fcc2c7 100644 --- a/src/dune_rules/parameterised_rules.ml +++ b/src/dune_rules/parameterised_rules.ml @@ -293,8 +293,7 @@ let instantiate ~sctx lib = match Lib_info.modules lib_info with | External None -> Code_error.raise "library has no modules" [ "lib", Lib.to_dyn lib ] | External (Some modules) -> - let dir = Path.Build.relative build_dir ".parameterised" in - let dir = Path.Build.relative dir (Lib_name.to_string (Lib.name lib)) in + let dir = Lib.Parameterised.dir ~build_dir lib in Memo.return (obj_dir_for_dep_rules dir, modules) | Local -> let local_lib = Lib.Local.of_lib_exn lib in From b89bc94b6ee6e6708801e1f42bb0ad7689b05273 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 27 Oct 2025 16:05:49 +0100 Subject: [PATCH 15/26] testing vendored parameterised library instantiation Signed-off-by: ArthurW --- .../test-cases/oxcaml/vendor-parameterised.t | 111 ++++++++++++++++++ 1 file changed, 111 insertions(+) create mode 100644 test/blackbox-tests/test-cases/oxcaml/vendor-parameterised.t diff --git a/test/blackbox-tests/test-cases/oxcaml/vendor-parameterised.t b/test/blackbox-tests/test-cases/oxcaml/vendor-parameterised.t new file mode 100644 index 00000000000..271dfce63bc --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/vendor-parameterised.t @@ -0,0 +1,111 @@ +Testing that vendoring a parameterized library works as expected: + + $ cat > dune-project < (lang dune 3.20) + > EOF + +Note that this root `dune-project` does not enables `(using oxcaml 0.1)`, but +will depend on a vendored project that does. + +We first set up a simple binary that depends on a vendored library: + + $ cat > dune < (executable (name bin) (libraries vendored.vendored_lib)) + > (vendored_dirs vendored) + > EOF + + $ cat > bin.ml < let () = print_endline (Vendored_lib.vendored_lib ()) + > EOF + +Then the vendored project: + + $ mkdir vendored + $ cat > vendored/dune-project < (lang dune 3.20) + > (using oxcaml 0.1) + > (package (name vendored)) + > EOF + +The parameter definition must reside in a separate folder from its implementation: + + $ mkdir vendored/param + $ cat > vendored/param/dune < (library_parameter (public_name vendored.param) (name param) (modules param)) + > EOF + +Then three vendored libraries, one for the implementation of the parameter, one +parameterised library, one library which depends on its instantation, and a +non-public executable: + + $ cat > vendored/dune < (library + > (public_name vendored.param_impl) + > (name param_impl) + > (modules param_impl) + > (implements param)) + > + > (library + > (public_name vendored.lib_param) + > (name lib_param) + > (modules lib_param) + > (parameters param)) + > + > (library + > (public_name vendored.vendored_lib) + > (name vendored_lib) + > (modules vendored_lib) + > (libraries + > (lib_param param_impl))) + > + > (executable + > (name vendored_bin) + > (modules vendored_bin) + > (libraries vendored_lib)) + > EOF + +A simple implementation for each: + + $ echo 'val v : string' > vendored/param/param.mli + $ echo 'let v = "impl"' > vendored/param_impl.ml + $ echo 'let lib_param () = "lib_param:" ^ Param.v' > vendored/lib_param.ml + $ echo 'let vendored_lib () = "vendored:" ^ Lib_param.lib_param ()' > vendored/vendored_lib.ml + $ echo 'let () = print_endline ("vendored_bin:" ^ Vendored_lib.vendored_lib ())' > vendored/vendored_bin.ml + +Running the executable requires instantiating the vendored +`(lib_param param_impl)` depdendency: + + $ dune exec ./bin.exe + vendored:lib_param:impl + $ ls _build/default/.parameterised/vendored.lib_param + vendored.lib_param!vendored.param_impl + +Similarly for the vendored binary: + + $ dune exec ./vendored/vendored_bin.exe + vendored_bin:vendored:lib_param:impl + +This run uses the same instantiation as the root, so no `vendored`-specific +instantation are created: + + $ ls vendored/_build/default/.parameterised/vendored.lib_param + ls: cannot access 'vendored/_build/default/.parameterised/vendored.lib_param': No such file or directory + [2] + +But building the executable from the vendored directory doesn't: + + $ dune exec --root=vendored ./vendored_bin.exe + Entering directory 'vendored' + Leaving directory 'vendored' + vendored_bin:vendored:lib_param:impl + $ ls vendored/_build/default/.parameterised/vendored.lib_param + vendored.lib_param!vendored.param_impl + +Same if built from the vendored directory: + + $ cd vendored + $ dune clean + $ dune exec ./vendored_bin.exe + vendored_bin:vendored:lib_param:impl + $ ls _build/default/.parameterised/vendored.lib_param + vendored.lib_param!vendored.param_impl From e52c677f09b44b400cc5bd4e7c9e067560566490 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 27 Oct 2025 16:28:32 +0100 Subject: [PATCH 16/26] fix: enable using-oxcaml in dune_package/lib_dep Signed-off-by: ArthurW --- src/dune_lang/lib_dep.ml | 5 +---- src/dune_lang/oxcaml.ml | 4 +++- src/dune_lang/oxcaml.mli | 1 + src/dune_rules/dune_package.ml | 9 +++++++-- 4 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src/dune_lang/lib_dep.ml b/src/dune_lang/lib_dep.ml index 7961b337352..75b024e032f 100644 --- a/src/dune_lang/lib_dep.ml +++ b/src/dune_lang/lib_dep.ml @@ -140,10 +140,7 @@ let decode ~allow_re_export = Select select ) ] <|> enter - ((* TODO art-w: oxcaml extension is not recognized by installed - libraries, which are missing a `(using oxcaml 0.1)` - let+ () = Syntax.since Oxcaml.syntax (0, 1) *) - let+ () = Syntax.since Stanza.syntax (3, 20) + (let+ () = Syntax.since Oxcaml.syntax (0, 1) and+ loc, lib = located Lib_name.decode and+ arguments, new_name = until_keyword diff --git a/src/dune_lang/oxcaml.ml b/src/dune_lang/oxcaml.ml index 22ae2457d06..466224863ad 100644 --- a/src/dune_lang/oxcaml.ml +++ b/src/dune_lang/oxcaml.ml @@ -1,11 +1,13 @@ open Import +let latest_version = 0, 1 + let syntax = Syntax.create ~name:"oxcaml" ~desc:"experimental support for OxCaml" ~experimental:true - [ (0, 1), `Since (3, 20) ] + [ latest_version, `Since (3, 20) ] ;; let parameterised_dir = ".parameterised" diff --git a/src/dune_lang/oxcaml.mli b/src/dune_lang/oxcaml.mli index fdab3917598..9239a32572f 100644 --- a/src/dune_lang/oxcaml.mli +++ b/src/dune_lang/oxcaml.mli @@ -1,4 +1,5 @@ open Import val syntax : Syntax.t +val latest_version : Syntax.Version.t val parameterised_dir : string diff --git a/src/dune_rules/dune_package.ml b/src/dune_rules/dune_package.ml index 6055b88983a..49f55fbd39f 100644 --- a/src/dune_rules/dune_package.ml +++ b/src/dune_rules/dune_package.ml @@ -609,11 +609,16 @@ module Or_meta = struct let parse file lexbuf = let dir = Path.parent_exn file in + let extensions = [ Dune_lang.Oxcaml.(syntax, latest_version) ] in + let with_extensions decoder = + List.fold_left extensions ~init:decoder ~f:(fun decoder (ext, version) -> + Syntax.set ext (Active version) decoder) + in match Vfile.parse_contents lexbuf ~f:(fun lang -> String_with_vars.set_decoding_env - (Pform.Env.initial ~stanza:lang.version ~extensions:[]) - (decode ~lang ~dir)) + (Pform.Env.initial ~stanza:lang.version ~extensions) + (with_extensions (decode ~lang ~dir))) with | contents -> Ok contents | exception User_error.E message -> Error message From fbe8f8294168c7270a11de282e965b80b06caeea Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 27 Oct 2025 17:26:16 +0100 Subject: [PATCH 17/26] fix: missing virtual dep in requires Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 12 ++--- src/dune_rules/parameterised_rules.ml | 66 +++++++++++++-------------- 2 files changed, 38 insertions(+), 40 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 49b240b6914..cde83425d24 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -714,7 +714,7 @@ let wrapped t = ;; (* We can't write a structural equality because of all the lazy fields *) -let equal : t -> t -> bool = phys_equal +let equal a b = Ordering.is_eq (compare a b) let hash = Poly.hash include Comparable.Make (T) @@ -972,8 +972,7 @@ end = struct | [] -> Resolve.Memo.return acc | (lib, stack) :: libs -> (match lib.implements, Lib_info.kind lib.info with - | None, Dune_file _ -> loop acc libs - | None, Parameter -> loop acc libs + | None, (Dune_file _ | Parameter) -> loop acc libs | None, Virtual -> loop (Map.set acc lib (No_impl stack)) libs | Some _, (Parameter | Virtual) -> assert false (* can't be virtual and implement *) @@ -1251,15 +1250,14 @@ end = struct | Parameter -> Resolve.Memo.return [ impl ] | Virtual -> let requires_for_closure_check = - List.filter requires ~f:(fun lib -> - not (Ordering.is_eq (compare lib impl))) + List.filter requires ~f:(fun lib -> not (equal lib impl)) in let+ () = check_forbidden requires_for_closure_check ~forbidden_libraries:(Map.singleton impl Loc.none) in - [] + [ impl ] | Dune_file _ -> Code_error.raise "expected Virtual or Parameter" @@ -2014,7 +2012,7 @@ end = struct find_internal db lib.name >>= function | Status.Found lib' -> - if Ordering.is_eq (Id.compare lib.unique_id lib'.unique_id) + if Id.equal lib.unique_id lib'.unique_id then Resolve.Memo.return () else ( let req_by = Dep_stack.to_required_by stack in diff --git a/src/dune_rules/parameterised_rules.ml b/src/dune_rules/parameterised_rules.ml index 539f8fcc2c7..0377cd31d45 100644 --- a/src/dune_rules/parameterised_rules.ml +++ b/src/dune_rules/parameterised_rules.ml @@ -150,39 +150,39 @@ let build_archive ~sctx ~mode ~obj_dir ~lib ~top_sorted_modules ~modules = let lib_hidden_deps ~sctx ~kind lib requires = let* requires = Resolve.read_memo requires in Memo.List.concat_map requires ~f:(fun dep -> - match Lib.compare lib dep with - | Eq -> Memo.return [] - | Lt | Gt -> - (match Lib.Parameterised.status dep with - | Complete -> - let+ cm = Resolve.read_memo (get_cm ~kind dep) in - [ cm ] - | Partial -> - Code_error.raise - "unexpected partial application" - [ "lib", Lib.to_dyn lib; "dep", Lib.to_dyn dep ] - | Not_parameterised -> - let lib = dep in - let lib_info = Lib.info dep in - let obj_dir = Lib_info.obj_dir lib_info in - let+ modules = - match Lib_info.modules lib_info with - | External None -> - Code_error.raise "dependency has no modules" [ "lib", Lib.to_dyn dep ] - | External (Some modules) -> Memo.return modules - | Local -> - let local_lib = Lib.Local.of_lib_exn lib in - let+ modules = Dir_contents.modules_of_local_lib sctx local_lib in - Modules.With_vlib.modules modules - in - Modules.With_vlib.fold_no_vlib_with_aliases - modules - ~init:[] - ~normal:(fun module_ acc -> - match Obj_dir.Module.cm_file obj_dir module_ ~kind:(Ocaml Cmi) with - | None -> acc - | Some cmi -> cmi :: acc) - ~alias:(fun _group acc -> acc))) + if Lib.equal lib dep + then Memo.return [] + else ( + match Lib.Parameterised.status dep with + | Complete -> + let+ cm = Resolve.read_memo (get_cm ~kind dep) in + [ cm ] + | Partial -> + Code_error.raise + "unexpected partial application" + [ "lib", Lib.to_dyn lib; "dep", Lib.to_dyn dep ] + | Not_parameterised -> + let lib = dep in + let lib_info = Lib.info dep in + let obj_dir = Lib_info.obj_dir lib_info in + let+ modules = + match Lib_info.modules lib_info with + | External None -> + Code_error.raise "dependency has no modules" [ "lib", Lib.to_dyn dep ] + | External (Some modules) -> Memo.return modules + | Local -> + let local_lib = Lib.Local.of_lib_exn lib in + let+ modules = Dir_contents.modules_of_local_lib sctx local_lib in + Modules.With_vlib.modules modules + in + Modules.With_vlib.fold_no_vlib_with_aliases + modules + ~init:[] + ~normal:(fun module_ acc -> + match Obj_dir.Module.cm_file obj_dir module_ ~kind:(Ocaml Cmi) with + | None -> acc + | Some cmi -> cmi :: acc) + ~alias:(fun _group acc -> acc))) >>| Dep.Set.of_files ;; From 5d93daa92409089f160c99c5af18440a4e0478b9 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 30 Oct 2025 13:14:19 +0100 Subject: [PATCH 18/26] fix CI Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 18 +++++++++++++----- src/dune_rules/parameterised_rules.ml | 4 +++- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index cde83425d24..f029d9568d5 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -706,11 +706,19 @@ let wrapped t = | None -> Resolve.Memo.return None | Some (This wrapped) -> Resolve.Memo.return (Some wrapped) | Some (From _) -> - let+ vlib = Memo.return (Option.value_exn t.implements) in - (match Lib_info.wrapped vlib.info with - | Some (From _) (* can't inherit this value in virtual libs *) | None -> - assert false (* will always be specified in dune package *) - | Some (This x) -> Some x) + let+ impl = Memo.return (Option.value_exn t.implements) in + (match Lib_info.kind impl.info with + | Parameter -> + (* A parameter is an unwrapped Singleton, but its implementation + should be wrapped. *) + Some (Wrapped.Simple true) + | Virtual -> + (match Lib_info.wrapped impl.info with + | Some (From _) (* can't inherit this value in virtual libs *) | None -> + assert false (* will always be specified in dune package *) + | Some (This x) -> Some x) + | Dune_file _ -> + Code_error.raise "expected Parameter or Virtual for implements" [ "lib", to_dyn t ]) ;; (* We can't write a structural equality because of all the lazy fields *) diff --git a/src/dune_rules/parameterised_rules.ml b/src/dune_rules/parameterised_rules.ml index 0377cd31d45..2d0bc76d4f1 100644 --- a/src/dune_rules/parameterised_rules.ml +++ b/src/dune_rules/parameterised_rules.ml @@ -231,7 +231,9 @@ let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~li let+ module_deps = Dep_graph.deps_of dep_graph module_ in let deps = List.map module_deps ~f:(fun module_ -> - apply_module_name module_ args |> obj_file ~obj_dir ~kind |> Path.build) + apply_module_name module_ args + |> obj_file ~obj_dir ~kind ?ext:None + |> Path.build) in Dep.Set.union lib_hidden_deps (Dep.Set.of_files (module_cmi :: deps)) in From d89ef6d48b6617712fecb5bbed70b97bfea95054 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 30 Oct 2025 15:11:02 +0100 Subject: [PATCH 19/26] documentation Signed-off-by: ArthurW --- doc/reference/library-dependencies.rst | 66 ++++++++++++++++++++++++++ src/dune_rules/lib.ml | 24 ++++++++-- 2 files changed, 85 insertions(+), 5 deletions(-) diff --git a/doc/reference/library-dependencies.rst b/doc/reference/library-dependencies.rst index 00e9225b32a..643618b3e10 100644 --- a/doc/reference/library-dependencies.rst +++ b/doc/reference/library-dependencies.rst @@ -68,3 +68,69 @@ be able to see ``foo`` independently of whether :doc:`implicit transitive dependencies` are allowed or not. When they are allowed, which is the default, all transitive dependencies are visible, whether they are marked as re-exported or not. + +Instantiating Parameterised Dependencies +---------------------------------------- + +This feature requires OxCaml, see :doc:`/reference/dune/library_parameter`. + +A parameterised dependency ``foo`` can be instantiated with the arguments +``bar``, ``qux`` using the syntax: + +.. code:: dune + + (foo bar qux) + +For example: + +.. code:: dune + + (library + (name test) + (libraries (foo bar qux))) + +The library ``foo`` must have declared the set of parameters it expects, and +the arguments given to the instantiation must implement a subset of these +parameters. The ordering of the arguments does not matter, as the instantiation +relies on the implemented parameter to uniquely identify each argument. +For executables, the parameterised dependencies must be fully instantiated. + +In the OCaml code, the instantiated library will be available under the module +name ``Foo``. To avoiding overlapping module names when instantiating the same +dependency multiple times, the syntax ``:as`` allows renaming the module. For +example: + +.. code:: dune + + (library + (name test) + (libraries + (foo a b :as foo_a_b) + (foo bar qux :as foo_bar_qux))) + +Then the instantiations will be available under the names ``Foo_a_b`` and +``Foo_bar_qux``. + +Dependencies automatically inherit the parameters of their parent library. +For example, assuming the parameterised library ``foo`` requires two +parameters ``p`` and ``q``: + +.. code:: dune + + (library + (name test) + (parameters p q) + (libraries + (foo :as foo_implicit) + (foo an_implementation_of_q :as foo_q) + (foo bar qux :as foo_bar_qux) + other_foo)) + +Then ``foo_implicit`` is implicitly ``(foo p q)``, +while ``(foo an_implementation_of_q)`` will only inherit the parameter ``p``. + +If ``other_foo``, which is not explicitly instantiated here, is also +parameterised by the parameters ``p`` (and) or ``q``, it will also inherit +its parent arguments. Dune will report an error if a dependency requires +parameters which have neither been given explicitly given via an instantiation +and are not listed in the parent library parameters. diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index f029d9568d5..03b4d6c7f0c 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -555,18 +555,32 @@ module Parameterised = struct ;; let apply_arguments t new_arguments = + (* The [new_arguments] are expected to be sorted in the same [parameter] + order as the existing arguments of [t], such that a linear in-order + traversal allow filling any unset parameter to the new argument. *) let open Resolve.O in let rec go acc existing' given' = match existing', given' with + | [], _ -> + (* Ignore remaining arguments *) + Resolve.return (List.rev acc) + | keep, [] -> + (* Keep the remaining existing parameters *) + Resolve.return (List.rev_append acc keep) | (param_intf, Some arg) :: existing, _ -> + (* Keep already applied parameter *) go ((param_intf, Some arg) :: acc) existing given' - | [], _ -> Resolve.return (List.rev acc) | ((param_intf, None) as keep) :: existing, (param_intf', arg) :: given -> (match compare param_intf param_intf' with - | Eq -> go ((param_intf, Some arg) :: acc) existing given - | Lt -> go (keep :: acc) existing given' - | Gt -> go acc existing' given) - | ((_, None) as keep) :: existing, [] -> go (keep :: acc) existing [] + | Eq -> + (* Apply the argument to the unset parameter *) + go ((param_intf, Some arg) :: acc) existing given + | Lt -> + (* Keep the existing parameter as being unknown *) + go (keep :: acc) existing given' + | Gt -> + (* Skip unwanted argument *) + go acc existing' given) in let* t_arguments = parameterised_arguments t in let+ arguments = go [] t_arguments new_arguments in From 83431aa47287867eb3dc22bb1e043eee322e2195 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Nov 2025 14:54:25 +0100 Subject: [PATCH 20/26] parameterised_name type Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 4 ++-- src/dune_rules/lib.mli | 4 ++-- src/dune_rules/parameterised_name.ml | 23 ++++++++++++----------- src/dune_rules/parameterised_name.mli | 12 ++++++------ src/dune_rules/parameterised_rules.ml | 3 +-- 5 files changed, 23 insertions(+), 23 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 03b4d6c7f0c..75bff61d890 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -670,7 +670,7 @@ module Parameterised = struct let parameterised_name t = let rec parameterised_name t = let args = arguments t |> List.map ~f:parameterised_name in - { Parameterised_name.name = Lib_name.to_string (name t); args } + { Parameterised_name.name = name t; args } in Parameterised_name.to_string (parameterised_name t) ;; @@ -710,7 +710,7 @@ module Parameterised = struct let+ name = resolve_main_module_name t and+ args = applied_modules t in match name with - | Some name -> { Parameterised_name.name = Module_name.to_string name; args } + | Some name -> { Parameterised_name.name; args } | None -> Code_error.raise "library missing main module name" [ "lib", to_dyn t ] ;; end diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index b6e6ad513f8..6b93e8b1e27 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -30,8 +30,8 @@ module Parameterised : sig } val arguments : t -> t list - val applied_modules : t -> Parameterised_name.t list Resolve.t - val applied_name : t -> Parameterised_name.t Resolve.t + val applied_modules : t -> Module_name.t Parameterised_name.t list Resolve.t + val applied_name : t -> Module_name.t Parameterised_name.t Resolve.t val requires : t -> t list Resolve.t val for_instance : build_dir:Path.Build.t -> ext_lib:string -> t -> t val dir : build_dir:Path.Build.t -> t -> Path.Build.t diff --git a/src/dune_rules/parameterised_name.ml b/src/dune_rules/parameterised_name.ml index ed18aa7090d..5d7d3d238f8 100644 --- a/src/dune_rules/parameterised_name.ml +++ b/src/dune_rules/parameterised_name.ml @@ -1,11 +1,11 @@ open Import -type t = - { name : string - ; args : t list +type 'a t = + { name : 'a + ; args : 'a t list } -let of_string ~sep str = +let of_string ~sep name_of_string str = let rec count_empty total = function | "" :: rest -> count_empty (total + 1) rest | rest -> total, rest @@ -20,10 +20,11 @@ let of_string ~sep str = in { name; args } in + let leaf name = { name = name_of_string name; args = [] } in let t, rest = match parts with | [] -> assert false - | name :: rest -> { name; args = [] }, rest + | name :: rest -> leaf name, rest in let rec go t rest = let depth, rest = count_empty 0 rest in @@ -32,17 +33,17 @@ let of_string ~sep str = assert (Int.equal depth 0); t | name :: rest -> - let t = apply depth t { name; args = [] } in + let t = apply depth t (leaf name) in go t rest in go t rest ;; -let to_string ~sep t = +let to_string ~sep string_of_name t = let sep = String.make 1 sep in let buf = Buffer.create 16 in let rec go apply_sep { name; args } = - Buffer.add_string buf name; + Buffer.add_string buf (string_of_name name); let apply_sep' = sep ^ apply_sep in List.iter args ~f:(fun arg -> Buffer.add_string buf apply_sep; @@ -53,10 +54,10 @@ let to_string ~sep t = ;; let to_module_name t = - let applied_name = to_string ~sep:'-' t in + let applied_name = to_string ~sep:'-' Module_name.to_string t in let module_name = Module_name.of_string_allow_invalid (Loc.none, applied_name) in Module_name.Unique.of_name_assuming_needs_no_mangling module_name ;; -let of_string str = of_string ~sep:'!' str -let to_string t = to_string ~sep:'!' t +let of_string str = of_string ~sep:'!' Lib_name.of_string str +let to_string t = to_string ~sep:'!' Lib_name.to_string t diff --git a/src/dune_rules/parameterised_name.mli b/src/dune_rules/parameterised_name.mli index ac94262a41b..2a2e0a9fc62 100644 --- a/src/dune_rules/parameterised_name.mli +++ b/src/dune_rules/parameterised_name.mli @@ -1,10 +1,10 @@ open Import -type t = - { name : string - ; args : t list +type 'a t = + { name : 'a + ; args : 'a t list } -val of_string : string -> t -val to_string : t -> string -val to_module_name : t -> Module_name.Unique.t +val of_string : string -> Lib_name.t t +val to_string : Lib_name.t t -> string +val to_module_name : Module_name.t t -> Module_name.Unique.t diff --git a/src/dune_rules/parameterised_rules.ml b/src/dune_rules/parameterised_rules.ml index 2d0bc76d4f1..ff50b6a8a68 100644 --- a/src/dune_rules/parameterised_rules.ml +++ b/src/dune_rules/parameterised_rules.ml @@ -187,7 +187,7 @@ let lib_hidden_deps ~sctx ~kind lib requires = ;; let apply_module_name module_ args = - let name = Module_name.Unique.to_string (Module.obj_name module_) in + let name = Module_name.Unique.to_name ~loc:Loc.none (Module.obj_name module_) in Parameterised_name.to_module_name { name; args } ;; @@ -331,7 +331,6 @@ let instantiate ~sctx lib = let resolve_instantiation scope str = let db = Scope.libs scope in let rec go { Parameterised_name.name; args } = - let name = Lib_name.of_string name in let+ lib = Lib.DB.find db name and+ args = Memo.List.map ~f:go args in match lib with From 91cfe1f90fd4fb804a568b571a7d1253fe18d819 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Nov 2025 15:12:21 +0100 Subject: [PATCH 21/26] simplify Signed-off-by: ArthurW --- src/dune_rules/parameterised_rules.ml | 19 +++++-------------- 1 file changed, 5 insertions(+), 14 deletions(-) diff --git a/src/dune_rules/parameterised_rules.ml b/src/dune_rules/parameterised_rules.ml index ff50b6a8a68..f702f980427 100644 --- a/src/dune_rules/parameterised_rules.ml +++ b/src/dune_rules/parameterised_rules.ml @@ -35,9 +35,8 @@ let build_instance ~sctx ~obj_dir ~mode instance = let ctx = Super_context.context sctx in let* ocaml = Context.ocaml ctx in let include_flags = - Action_builder.of_memo - @@ - let+ requires = Resolve.read_memo requires in + let open Action_builder.O in + let+ requires = Resolve.read requires in Lib_flags.L.include_flags ~direct_libs:requires ~hidden_libs:[] @@ -62,9 +61,8 @@ let build_instance ~sctx ~obj_dir ~mode instance = ; A "-instantiate" ; Dep module_ ; Dyn - (Action_builder.of_memo - @@ - let+ args = Resolve.read_memo args in + (let open Action_builder.O in + let+ args = Resolve.read args in Command.Args.Deps args) ; Dyn (let open Action_builder.O in @@ -250,13 +248,6 @@ let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~li Module_name.Map.add_exn acc (Module.name module_) instance) ;; -let iter_modes_concurrently ~(f : Ocaml.Mode.t -> unit Memo.t) = - let t = Mode.Dict.make_both true in - let+ () = Memo.when_ t.byte (fun () -> f Byte) - and+ () = Memo.when_ t.native (fun () -> f Native) in - () -;; - let dep_graph ~obj_dir ~modules impl_only = let per_module = List.fold_left impl_only ~init:Module_name.Unique.Map.empty ~f:(fun acc module_ -> @@ -313,7 +304,7 @@ let instantiate ~sctx lib = let lib = Lib.Parameterised.for_instance ~build_dir ~ext_lib lib in let obj_dir = Lib_info.obj_dir (Lib.info lib) |> Obj_dir.as_local_exn in let top_sorted_modules = Dep_graph.top_closed_implementations dep_graph impl_only in - iter_modes_concurrently ~f:(fun mode -> + Memo.parallel_iter Ocaml.Mode.all ~f:(fun mode -> let* modules = build_modules ~sctx From 28947452eaf6168ba5d1ca161291652c703c1e9c Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Nov 2025 15:15:26 +0100 Subject: [PATCH 22/26] remove root_module hack for unwrapped dependencies Signed-off-by: ArthurW --- src/dune_rules/root_module.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dune_rules/root_module.ml b/src/dune_rules/root_module.ml index 5d0dd2e8804..caf1f05404b 100644 --- a/src/dune_rules/root_module.ml +++ b/src/dune_rules/root_module.ml @@ -16,5 +16,5 @@ let entries sctx ~requires_compile = Action_builder.List.map requires ~f:(fun lib -> Action_builder.of_memo (entry_module_names sctx lib) >>= Resolve.read) in - Action_builder.return (List.concat l |> List.sort_uniq ~compare:Module_name.compare) + Action_builder.return (List.concat l) ;; From c9e5db8221a26d4f4e295e60ffb4deef6a1d3cfa Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Nov 2025 15:43:39 +0100 Subject: [PATCH 23/26] fix package requires order Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 9 ++++++--- .../test-cases/oxcaml/instantiate-parameterised.t | 8 ++++---- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 75bff61d890..230fd948126 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -1285,9 +1285,12 @@ end = struct "expected Virtual or Parameter" [ "implements", to_dyn impl ]) in - List.concat [ requires_implements; requires_params; requires ] - |> Set.of_list - |> Set.to_list + let requires = List.concat [ requires_implements; requires_params; requires ] in + let _, requires = + List.fold_left requires ~init:(Set.empty, []) ~f:(fun (seen, lst) lib -> + if Set.mem seen lib then seen, lst else Set.add seen lib, lib :: lst) + in + List.rev requires in let resolve_impl impl_name = let open Resolve.Memo.O in diff --git a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t index 1637c97f496..a5258f154b9 100644 --- a/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t +++ b/test/blackbox-tests/test-cases/oxcaml/instantiate-parameterised.t @@ -658,7 +658,7 @@ The `dune-package` should list the different instantiations in the dependencies: (archives (byte lib_ab/lib_ab.cma) (native lib_ab/lib_ab.cmxa)) (plugins (byte lib_ab/lib_ab.cma) (native lib_ab/lib_ab.cmxs)) (native_archives lib_ab/lib_ab.a) - (requires project.a (project.a_of_b) project.b) + (requires project.a project.b (project.a_of_b)) (parameters project.a project.b) (main_module_name Lib_ab) (modes byte native) @@ -674,12 +674,12 @@ The `dune-package` should list the different instantiations in the dependencies: (plugins (byte lib_apply/lib_apply.cma) (native lib_apply/lib_apply.cmxs)) (native_archives lib_apply/lib_apply.a) (requires - project.a_impl - (project.a_of_b) project.b - project.b_impl + project.a_impl (project.lib_ab project.a_impl) + project.b_impl (project.lib_ab project.a_impl project.b_impl) + (project.a_of_b) (project.lib_ab project.a_of_b) (project.lib_ab project.a_of_b project.b_impl)) (parameters project.b) From 78324a418446df8dc6b56e802744652b07411ba2 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 4 Nov 2025 10:30:01 +0100 Subject: [PATCH 24/26] skip non-parameterised libraries Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 92 +++++++++++++++++++++++-------------------- 1 file changed, 49 insertions(+), 43 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 230fd948126..00ce9719735 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -558,34 +558,37 @@ module Parameterised = struct (* The [new_arguments] are expected to be sorted in the same [parameter] order as the existing arguments of [t], such that a linear in-order traversal allow filling any unset parameter to the new argument. *) - let open Resolve.O in - let rec go acc existing' given' = - match existing', given' with - | [], _ -> - (* Ignore remaining arguments *) - Resolve.return (List.rev acc) - | keep, [] -> - (* Keep the remaining existing parameters *) - Resolve.return (List.rev_append acc keep) - | (param_intf, Some arg) :: existing, _ -> - (* Keep already applied parameter *) - go ((param_intf, Some arg) :: acc) existing given' - | ((param_intf, None) as keep) :: existing, (param_intf', arg) :: given -> - (match compare param_intf param_intf' with - | Eq -> - (* Apply the argument to the unset parameter *) - go ((param_intf, Some arg) :: acc) existing given - | Lt -> - (* Keep the existing parameter as being unknown *) - go (keep :: acc) existing given' - | Gt -> - (* Skip unwanted argument *) - go acc existing' given) - in - let* t_arguments = parameterised_arguments t in - let+ arguments = go [] t_arguments new_arguments in - let arguments = List.map ~f:snd arguments in - { t with arguments } + match t.arguments with + | [] -> Resolve.return t + | _ -> + let open Resolve.O in + let rec go acc existing' given' = + match existing', given' with + | [], _ -> + (* Ignore remaining arguments *) + Resolve.return (List.rev acc) + | keep, [] -> + (* Keep the remaining existing parameters *) + Resolve.return (List.rev_append acc keep) + | (param_intf, Some arg) :: existing, _ -> + (* Keep already applied parameter *) + go ((param_intf, Some arg) :: acc) existing given' + | ((param_intf, None) as keep) :: existing, (param_intf', arg) :: given -> + (match compare param_intf param_intf' with + | Eq -> + (* Apply the argument to the unset parameter *) + go ((param_intf, Some arg) :: acc) existing given + | Lt -> + (* Keep the existing parameter as being unknown *) + go (keep :: acc) existing given' + | Gt -> + (* Skip unwanted argument *) + go acc existing' given) + in + let* t_arguments = parameterised_arguments t in + let+ arguments = go [] t_arguments new_arguments in + let arguments = List.map ~f:snd arguments in + { t with arguments } ;; let make_argument (loc, arg) = @@ -628,21 +631,24 @@ module Parameterised = struct ;; let complement_arguments ~parent dep = - let open Resolve.O in - let* parent_arguments = parameterised_arguments parent in - let parent_arguments = - List.filter_map parent_arguments ~f:(fun (param, opt_arg) -> - Option.map opt_arg ~f:(fun arg -> param, arg)) - in - let* arguments = - Resolve.List.map dep.arguments ~f:(fun opt_arg -> - match opt_arg with - | None -> Resolve.return None - | Some argument -> - let+ arg = apply_arguments argument.arg parent_arguments in - Some { argument with arg }) - in - apply_arguments { dep with arguments } parent_arguments + match dep.arguments with + | [] -> Resolve.return dep + | _ -> + let open Resolve.O in + let* parent_arguments = parameterised_arguments parent in + let parent_arguments = + List.filter_map parent_arguments ~f:(fun (param, opt_arg) -> + Option.map opt_arg ~f:(fun arg -> param, arg)) + in + let* arguments = + Resolve.List.map dep.arguments ~f:(fun opt_arg -> + match opt_arg with + | None -> Resolve.return None + | Some argument -> + let+ arg = apply_arguments argument.arg parent_arguments in + Some { argument with arg }) + in + apply_arguments { dep with arguments } parent_arguments ;; let remove_arguments lib = { lib with parameters = Resolve.return []; arguments = [] } From fed00c92e88d3d1aae64bbe1f5033feaea53004a Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 5 Nov 2025 16:09:00 +0100 Subject: [PATCH 25/26] simplify Signed-off-by: ArthurW --- src/dune_rules/lib.ml | 60 +++++++++++++----------------------------- src/dune_rules/lib.mli | 8 ------ 2 files changed, 19 insertions(+), 49 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 00ce9719735..6e70e184e4a 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -374,7 +374,7 @@ module T = struct ; pps : t list Resolve.t ; resolved_selects : Resolved_select.t list Resolve.t ; parameters : t list Resolve.t - ; arguments : argument option list + ; arguments : t option list ; implements : t Resolve.t option ; project : Dune_project.t option ; (* these fields cannot be forced until the library is instantiated *) @@ -382,22 +382,14 @@ module T = struct ; sub_systems : Sub_system0.Instance.t Memo.Lazy.t Sub_system_name.Map.t } - and argument = - { arg : t - ; param_name : Module_name.t - ; arg_name : Module_name.t - ; loc : Loc.t - } - let rec compare (x : t) (y : t) = match Id.compare x.unique_id y.unique_id with | (Lt | Gt) as cmp -> cmp | Eq -> compare_arguments x y and compare_arguments a b = - List.compare a.arguments b.arguments ~compare:(Option.compare compare_argument) - - and compare_argument x y = compare x.arg y.arg + List.compare a.arguments b.arguments ~compare:(Option.compare compare) + ;; let to_dyn t = Dyn.record @@ -518,34 +510,27 @@ let resolve_main_module_name t = let main_module_name t = Memo.return (resolve_main_module_name t) module Parameterised = struct - type nonrec argument = argument = - { arg : t - ; param_name : Module_name.t - ; arg_name : Module_name.t - ; loc : Loc.t - } - type status = | Not_parameterised | Partial | Complete let status t = - if List.for_all t.arguments ~f:Option.is_none - then Not_parameterised - else ( + match t.arguments with + | [] -> Not_parameterised + | _ -> let rec check_instantiate lib = List.for_all lib.arguments ~f:(function | None -> false - | Some arg -> check_instantiate arg.arg) + | Some arg -> check_instantiate arg) in - if check_instantiate t then Complete else Partial) + if check_instantiate t then Complete else Partial ;; let arguments t = List.map t.arguments ~f:(function | None -> Code_error.raise "expected complete application" [ "lib", to_dyn t ] - | Some { arg; _ } -> arg) + | Some arg -> arg) ;; let parameterised_arguments t = @@ -594,19 +579,12 @@ module Parameterised = struct let make_argument (loc, arg) = let open Resolve.O in let* arg = arg in - let* param = + let+ param = match arg.implements with | Some param -> param | None -> Error.missing_implements ~loc arg.info in - let+ param_name = resolve_main_module_name param - and+ arg_name = resolve_main_module_name arg in - ( param - , { arg - ; param_name = Option.value_exn param_name - ; arg_name = Option.value_exn arg_name - ; loc - } ) + param, arg ;; let make_arguments arguments = @@ -644,9 +622,9 @@ module Parameterised = struct Resolve.List.map dep.arguments ~f:(fun opt_arg -> match opt_arg with | None -> Resolve.return None - | Some argument -> - let+ arg = apply_arguments argument.arg parent_arguments in - Some { argument with arg }) + | Some arg -> + let+ arg = apply_arguments arg parent_arguments in + Some arg) in apply_arguments { dep with arguments } parent_arguments ;; @@ -662,11 +640,11 @@ module Parameterised = struct let lib_arguments = List.filter_map lib.arguments ~f:(function | None -> None - | Some arg -> Some arg.arg) + | Some arg -> Some arg) in let deps = lib_arguments @ deps in let deps = - match lib_arguments with + match lib.arguments with | [] -> deps | _ -> remove_arguments lib :: deps in @@ -699,12 +677,12 @@ module Parameterised = struct let rec for_instance ~build_dir ~ext_lib t = match info ~build_dir ~ext_lib t with - | None -> { t with arguments = [] } + | None -> remove_arguments t | Some info -> let arguments = List.map t.arguments ~f:(function | None -> None - | Some arg -> Some { arg with arg = for_instance ~build_dir ~ext_lib arg.arg }) + | Some arg -> Some (for_instance ~build_dir ~ext_lib arg)) in { t with info = Lib_info.of_local info; arguments } ;; @@ -2567,7 +2545,7 @@ let to_dune_lib ; arguments = List.filter_map args ~f:(function | None -> None - | Some arg -> Some (arg.loc, mangled_name arg.arg)) + | Some arg -> Some (Loc.none, mangled_name arg)) ; new_name = None })) in diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index 6b93e8b1e27..37d8c7eb47e 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -21,14 +21,6 @@ module Parameterised : sig | Complete val status : t -> status - - type argument = private - { arg : t - ; param_name : Module_name.t - ; arg_name : Module_name.t - ; loc : Loc.t - } - val arguments : t -> t list val applied_modules : t -> Module_name.t Parameterised_name.t list Resolve.t val applied_name : t -> Module_name.t Parameterised_name.t Resolve.t From 008ed88a169e470c66aebc45a398058a048fc077 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 5 Nov 2025 13:56:06 +0100 Subject: [PATCH 26/26] feat(oxcaml): parameterised inline_tests Signed-off-by: ArthurW --- doc/tests.rst | 15 ++ src/dune_rules/inline_tests.ml | 13 +- src/dune_rules/inline_tests_info.ml | 8 + src/dune_rules/inline_tests_info.mli | 1 + src/dune_rules/parameterised_rules.ml | 24 ++- .../oxcaml/parameterised-inline-test.t | 153 ++++++++++++++++++ 6 files changed, 207 insertions(+), 7 deletions(-) create mode 100644 test/blackbox-tests/test-cases/oxcaml/parameterised-inline-test.t diff --git a/doc/tests.rst b/doc/tests.rst index f826c1b1c39..c6545865f4a 100644 --- a/doc/tests.rst +++ b/doc/tests.rst @@ -288,6 +288,21 @@ a ``deps`` field the ``inline_tests`` field. The argument of this (inline_tests (deps data.txt)) (preprocess (pps ppx_expect))) +Specifying Inline Test arguments for Parameterised Libraries +------------------------------------------------------------ + +If your library is parameterised (see +:doc:`/reference/dune/library_parameter`), you must specify which +implementation of the parameters to use with the ``arguments`` field: + +.. code:: ocaml + + (library + (name foo) + (parameters a_param b_param) + (inline_tests + (arguments a_impl b_impl))) + Passing Special Arguments to the Test Runner -------------------------------------------- diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index 6176b340371..50374450245 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -264,7 +264,18 @@ include Sub_system.Register_end_point (struct Resolve.Memo.List.concat_map backends ~f:(fun (backend : Backend.t) -> backend.runner_libraries) in - let* lib = Lib.DB.resolve lib_db (loc, Library.best_name lib) in + let* arguments = + Resolve.Memo.lift_memo + @@ Memo.List.map info.arguments ~f:(fun (loc, dep) -> + let open Memo.O in + let+ dep = Lib.DB.resolve lib_db (loc, dep) in + loc, dep) + in + let* lib = + let open Memo.O in + let+ lib = Lib.DB.resolve lib_db (loc, Library.best_name lib) in + Lib.Parameterised.instantiate ~loc lib arguments ~parent_parameters:[] + in let* more_libs = Resolve.Memo.List.map info.libraries ~f:(Lib.DB.resolve lib_db) in diff --git a/src/dune_rules/inline_tests_info.ml b/src/dune_rules/inline_tests_info.ml index 73a06e077e9..a948c25a166 100644 --- a/src/dune_rules/inline_tests_info.ml +++ b/src/dune_rules/inline_tests_info.ml @@ -134,6 +134,7 @@ module Tests = struct ; executable_link_flags : Ordered_set_lang.Unexpanded.t ; backend : (Loc.t * Lib_name.t) option ; libraries : (Loc.t * Lib_name.t) list + ; arguments : (Loc.t * Lib_name.t) list ; enabled_if : Blang.t } @@ -165,6 +166,12 @@ module Tests = struct ocaml_flags, link_flags)) and+ backend = field_o "backend" (located Lib_name.decode) and+ libraries = field "libraries" (repeat (located Lib_name.decode)) ~default:[] + and+ arguments = + field + "arguments" + (Dune_lang.Syntax.since Dune_lang.Oxcaml.syntax (0, 1) + >>> repeat (located Lib_name.decode)) + ~default:[] and+ modes = field "modes" @@ -180,6 +187,7 @@ module Tests = struct ; executable_link_flags ; backend ; libraries + ; arguments ; modes ; enabled_if }) diff --git a/src/dune_rules/inline_tests_info.mli b/src/dune_rules/inline_tests_info.mli index f9ce6055d4a..81fa4eaab1b 100644 --- a/src/dune_rules/inline_tests_info.mli +++ b/src/dune_rules/inline_tests_info.mli @@ -46,6 +46,7 @@ module Tests : sig ; executable_link_flags : Ordered_set_lang.Unexpanded.t ; backend : (Loc.t * Lib_name.t) option ; libraries : (Loc.t * Lib_name.t) list + ; arguments : (Loc.t * Lib_name.t) list ; enabled_if : Blang.t } diff --git a/src/dune_rules/parameterised_rules.ml b/src/dune_rules/parameterised_rules.ml index f702f980427..07fed572a86 100644 --- a/src/dune_rules/parameterised_rules.ml +++ b/src/dune_rules/parameterised_rules.ml @@ -248,12 +248,19 @@ let build_modules ~sctx ~obj_dir ~modules_obj_dir ~dep_graph ~mode ~requires ~li Module_name.Map.add_exn acc (Module.name module_) instance) ;; -let dep_graph ~obj_dir ~modules impl_only = +let dep_graph ~ocaml_version ~preprocess ~obj_dir ~modules impl_only = + let pp_map = + Staged.unstage + @@ Pp_spec.pped_modules_map + (Dune_lang.Preprocess.Per_module.without_instrumentation preprocess) + ocaml_version + in let per_module = List.fold_left impl_only ~init:Module_name.Unique.Map.empty ~f:(fun acc module_ -> let module_name_unique = Module.obj_name module_ in let deps = let open Action_builder.O in + let module_ = pp_map module_ in let+ deps = Dep_rules.read_immediate_deps_of module_ ~modules ~obj_dir ~ml_kind:Impl in @@ -276,10 +283,8 @@ let obj_dir_for_dep_rules dir = let instantiate ~sctx lib = let ctx = Super_context.context sctx in let build_dir = Context.build_dir ctx in - let* { Lib_config.ext_lib; _ } = - let+ ocaml = ctx |> Context.ocaml in - ocaml.lib_config - in + let* ocaml = Context.ocaml ctx in + let ext_lib = ocaml.lib_config.ext_lib in let lib_info = Lib.info lib in let modules_obj_dir = Lib_info.obj_dir lib_info in let* deps_obj_dir, modules = @@ -295,7 +300,14 @@ let instantiate ~sctx lib = modules_obj_dir, Modules.With_vlib.modules modules in let impl_only = Modules.With_vlib.impl_only modules in - let dep_graph = dep_graph ~obj_dir:deps_obj_dir ~modules impl_only in + let dep_graph = + dep_graph + ~ocaml_version:ocaml.version + ~preprocess:(Lib_info.preprocess lib_info) + ~obj_dir:deps_obj_dir + ~modules + impl_only + in let* requires = Lib.closure ~linking:true [ lib ] |> Resolve.Memo.map diff --git a/test/blackbox-tests/test-cases/oxcaml/parameterised-inline-test.t b/test/blackbox-tests/test-cases/oxcaml/parameterised-inline-test.t new file mode 100644 index 00000000000..cfce39ca456 --- /dev/null +++ b/test/blackbox-tests/test-cases/oxcaml/parameterised-inline-test.t @@ -0,0 +1,153 @@ +Testing the instantiation of parameterised inline tests. + + $ cat >> dune-project < (lang dune 3.20) + > (using oxcaml 0.1) + > EOF + +We first define a parameter signature: + + $ mkdir param + $ echo 'val param : string' > param/param.mli + $ cat > param/dune < (library_parameter (name param)) + > EOF + +Then a parameterised library, which uses inline tests: + + $ mkdir lib + $ cat > lib/lib.ml < let param = Param.param + > let%test _ = Param.param = "impl" + > EOF + $ cat > lib/dune < (library + > (name lib) + > (parameters param) + > (inline_tests) + > (preprocess (pps ppx_inline_test))) + > EOF + +Running the test fails, because we did not specify an implementation for the +parameter: + + $ dune runtest + File "lib/dune", lines 1-5, characters 0-97: + 1 | (library + 2 | (name lib) + 3 | (parameters param) + 4 | (inline_tests) + 5 | (preprocess (pps ppx_inline_test))) + Error: Parameter "param" is missing. + -> required by + _build/default/lib/.lib.inline-tests/.t.eobjs/native/dune__exe__Main.cmx + -> required by _build/default/lib/.lib.inline-tests/inline-test-runner.exe + -> required by _build/default/lib/.lib.inline-tests/partitions-best + -> required by alias lib/runtest-lib in lib/dune:4 + -> required by alias lib/runtest in lib/dune:1 + Hint: Pass an argument implementing param to the dependency, or add + (parameters param) + [1] + +We add an implementation: + + $ mkdir impl + $ echo 'let param = "impl"' > impl/impl.ml + $ cat > impl/dune < (library + > (name impl) + > (implements param)) + > EOF + +And specify that `(inline_tests)` should use it with `(arguments impl)`: + + $ cat > lib/dune < (library + > (name lib) + > (parameters param) + > (inline_tests (arguments impl)) + > (preprocess (pps ppx_inline_test))) + > EOF + +It should work: + + $ dune runtest + +We break the test to confirm that the inline test is running: + + $ cat > lib/lib.ml < let param = "lib(" ^ Param.param ^ ")" + > let%test _ = Param.param = "not impl" + > EOF + + $ dune runtest + File "lib/lib.ml", line 2, characters 0-37: <> is false. + + FAILED 1 / 1 tests + [1] + +Using another implementation: + + $ mkdir not_impl + $ echo 'let param = "not impl"' > not_impl/not_impl.ml + $ cat > not_impl/dune < (library + > (name not_impl) + > (implements param)) + > EOF + + $ cat > lib/dune < (library + > (name lib) + > (parameters param) + > (inline_tests (arguments not_impl)) + > (preprocess (pps ppx_inline_test))) + > EOF + +This now works: + + $ dune runtest + +Adding another library which has a dependency on the parameterised `lib`: + + $ mkdir lib2 + $ cat > lib2/lib2_util.ml < let lib_param = Lib.param + > EOF + $ cat > lib2/lib2.ml < let%test _ = Lib2_util.lib_param = "lib(impl)" + > EOF + $ cat > lib2/dune < (library + > (name lib2) + > (parameters param) + > (libraries lib) + > (inline_tests (arguments impl)) + > (preprocess (pps ppx_inline_test))) + > EOF + +(Note that the library has two files, which triggers the inline_test +preprocessor to generate `.pp.ml` files, which influences how the parameterised +libraries can read the ocamldep outputs since the filenames are not the +unpreprocessed ones.) + +This should also work: + + $ dune runtest + +Using the wrong implementation should break the test again: + + $ cat > lib2/dune < (library + > (name lib2) + > (parameters param) + > (libraries lib) + > (inline_tests (arguments not_impl)) + > (preprocess (pps ppx_inline_test))) + > EOF + + $ dune runtest + File "lib2/lib2.ml", line 1, characters 0-46: <> is false. + + FAILED 1 / 1 tests + [1]