From 9ab1a4a371ae0879aa214a3e74b426ca8df5658a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 20 Oct 2023 09:57:22 -0600 Subject: [PATCH 01/20] feature(pkg): thread monad through 0install solver (#8962) Signed-off-by: Rudi Grinberg --- bin/pkg.ml | 28 +- otherlibs/stdune/src/list.mli | 2 + src/dune_pkg/dune | 1 + src/dune_pkg/opam_solver.ml | 60 +++- src/dune_pkg/opam_solver.mli | 2 +- .../0install-solver/src/solver/diagnostics.ml | 16 +- vendor/0install-solver/src/solver/s.ml | 27 +- .../0install-solver/src/solver/solver_core.ml | 61 ++-- .../src/solver/zeroinstall_solver.mli | 10 +- vendor/opam-0install/lib/dir_context.ml | 266 +++++++++--------- vendor/opam-0install/lib/dir_context.mli | 5 +- vendor/opam-0install/lib/model.ml | 17 +- vendor/opam-0install/lib/model.mli | 4 +- vendor/opam-0install/lib/s.ml | 12 +- vendor/opam-0install/lib/solver.ml | 20 +- vendor/opam-0install/lib/solver.mli | 10 +- vendor/opam-0install/lib/switch_context.ml | 131 ++++----- vendor/opam-0install/lib/switch_context.mli | 30 +- 18 files changed, 402 insertions(+), 300 deletions(-) diff --git a/bin/pkg.ml b/bin/pkg.ml index 903d01d2f6f3..db546caa98d4 100644 --- a/bin/pkg.ml +++ b/bin/pkg.ml @@ -408,20 +408,24 @@ module Lock = struct ~solver_env_from_context ~sys_bindings_from_current_system in - let+ repos = + let* repos = get_repos repos solver_env ~opam_repository_path ~opam_repository_url in - match - Console.Status_line.with_overlay - (Constant (Pp.text "Solving for Build Plan")) - ~f:(fun () -> - Dune_pkg.Opam_solver.solve_lock_dir - solver_env - version_preference - repos - ~local_packages - ~experimental_translate_opam_filters) - with + let overlay = + Console.Status_line.add_overlay (Constant (Pp.text "Solving for Build Plan")) + in + Fiber.finalize + ~finally:(fun () -> + Console.Status_line.remove_overlay overlay; + Fiber.return ()) + (fun () -> + Dune_pkg.Opam_solver.solve_lock_dir + solver_env + version_preference + repos + ~local_packages + ~experimental_translate_opam_filters) + >>| function | Error (`Diagnostic_message message) -> Error (context_name, message) | Ok { lock_dir; files; _ } -> let summary_message = diff --git a/otherlibs/stdune/src/list.mli b/otherlibs/stdune/src/list.mli index 374a295ebd4c..ff341d303012 100644 --- a/otherlibs/stdune/src/list.mli +++ b/otherlibs/stdune/src/list.mli @@ -60,3 +60,5 @@ val max : 'a list -> f:('a -> 'a -> Ordering.t) -> 'a option val mem : 'a list -> 'a -> equal:('a -> 'a -> bool) -> bool val split_while : 'a t -> f:('a -> bool) -> 'a t * 'a t val truncate : max_length:int -> 'a t -> [> `Not_truncated of 'a t | `Truncated of 'a t ] +val of_seq : 'a Seq.t -> 'a t +val to_seq : 'a t -> 'a Seq.t diff --git a/src/dune_pkg/dune b/src/dune_pkg/dune index c4410a3515e5..134a2b095f7b 100644 --- a/src/dune_pkg/dune +++ b/src/dune_pkg/dune @@ -18,6 +18,7 @@ opam_state opam_0install build_info + zeroinstall_solver fmt xdg) (instrumentation diff --git a/src/dune_pkg/opam_solver.ml b/src/dune_pkg/opam_solver.ml index 3baaddebec04..47f8fdc1abd4 100644 --- a/src/dune_pkg/opam_solver.ml +++ b/src/dune_pkg/opam_solver.ml @@ -1,6 +1,27 @@ open Import +open Fiber.O + +module Monad : Opam_0install.S.Monad with type 'a t = 'a Fiber.t = struct + type 'a t = 'a Fiber.t + + module O = Fiber.O + + let return a = Fiber.return a + + module Seq = struct + let parallel_map f t = + Fiber.parallel_map (List.of_seq t) ~f |> Fiber.map ~f:List.to_seq + ;; + end + + module List = struct + let iter f x = Fiber.sequential_iter x ~f + let iter2 f x y = Fiber.sequential_iter (List.combine x y) ~f:(fun (x, y) -> f x y) + end +end module Context_for_dune = struct + type 'a monad = 'a Monad.t type filtered_formula = OpamTypes.filtered_formula type filter = OpamTypes.filter @@ -98,6 +119,7 @@ module Context_for_dune = struct ;; let candidates t name = + let+ () = Fiber.return () in match OpamPackage.Name.Map.find_opt name t.local_packages with | Some opam_file -> let version = @@ -153,7 +175,7 @@ module Context_for_dune = struct ;; end -module Solver = Opam_0install.Solver.Make (Context_for_dune) +module Solver = Opam_0install.Solver.Make (Monad) (Context_for_dune) let is_valid_global_variable_name = function | "root" -> false @@ -533,26 +555,36 @@ let opam_package_to_lock_file_pkg ;; let solve_package_list local_package_names context = - let result = - try + let* result = + Fiber.collect_errors (fun () -> (* [Solver.solve] returns [Error] when it's unable to find a solution to the dependencies, but can also raise exceptions, for example if opam is unable to parse an opam file in the package repository. To prevent an unexpected opam exception from crashing dune, we catch all exceptions raised by the solver and report them as [User_error]s instead. *) - Solver.solve context local_package_names - with - | OpamPp.(Bad_format _ | Bad_format_list _ | Bad_version _) as bad_format -> - User_error.raise [ Pp.text (OpamPp.string_of_bad_format bad_format) ] - | unexpected_exn -> - Code_error.raise - "Unexpected exception raised while solving dependencies" - [ "exception", Exn.to_dyn unexpected_exn ] + Solver.solve context local_package_names) + >>| function + | Ok (Ok res) -> Ok res + | Ok (Error e) -> Error (`Diagnostics e) + | Error [] -> assert false + | Error (exn :: _) -> + (* CR-rgrinberg: this needs to be handled right *) + Error (`Exn exn.exn) in match result with - | Error e -> Error (`Diagnostic_message (Solver.diagnostics e |> Pp.text)) - | Ok packages -> Ok (Solver.packages_of_result packages) + | Error (`Exn exn) -> + (match exn with + | OpamPp.(Bad_format _ | Bad_format_list _ | Bad_version _) as bad_format -> + User_error.raise [ Pp.text (OpamPp.string_of_bad_format bad_format) ] + | unexpected_exn -> + Code_error.raise + "Unexpected exception raised while solving dependencies" + [ "exception", Exn.to_dyn unexpected_exn ]) + | Error (`Diagnostics e) -> + let+ diagnostics = Solver.diagnostics e in + Error (`Diagnostic_message (Pp.text diagnostics)) + | Ok packages -> Fiber.return @@ Ok (Solver.packages_of_result packages) ;; (* Scan a path recursively down retrieving a list of all files together with their @@ -611,7 +643,7 @@ let solve_lock_dir Context_for_dune.create ~solver_env ~repos ~version_preference ~local_packages in solve_package_list (OpamPackage.Name.Map.keys local_packages) context - |> Result.map ~f:(fun solution -> + >>| Result.map ~f:(fun solution -> (* don't include local packages in the lock dir *) let all_package_names = List.map solution ~f:OpamPackage.name |> OpamPackage.Name.Set.of_list diff --git a/src/dune_pkg/opam_solver.mli b/src/dune_pkg/opam_solver.mli index 56ef65b0a078..2bbcc261323e 100644 --- a/src/dune_pkg/opam_solver.mli +++ b/src/dune_pkg/opam_solver.mli @@ -13,4 +13,4 @@ val solve_lock_dir -> Opam_repo.t list -> local_packages:Opam_repo.With_file.t Package_name.Map.t -> experimental_translate_opam_filters:bool - -> (Solver_result.t, [ `Diagnostic_message of _ Pp.t ]) result + -> (Solver_result.t, [ `Diagnostic_message of _ Pp.t ]) result Fiber.t diff --git a/vendor/0install-solver/src/solver/diagnostics.ml b/vendor/0install-solver/src/solver/diagnostics.ml index 84cf1ebfb7e3..170d45e5fb96 100644 --- a/vendor/0install-solver/src/solver/diagnostics.ml +++ b/vendor/0install-solver/src/solver/diagnostics.ml @@ -8,7 +8,9 @@ module List = Solver_core.List let pf = Format.fprintf -module Make (Results : S.SOLVER_RESULT) = struct +module Make (Monad : S.Monad) (Results : S.SOLVER_RESULT with type 'a Input.monad := 'a Monad.t) = struct + open Monad.O + module Model = Results.Input module RoleMap = Results.RoleMap @@ -409,16 +411,18 @@ module Make (Results : S.SOLVER_RESULT) = struct let of_result result = let impls = Results.to_map result in let root_req = Results.requirements result in - let report = + let+ report = let get_selected role sel = let impl = Results.unwrap sel in let diagnostics = lazy (Results.explain result role) in let impl = if impl == Model.dummy_impl then None else Some impl in - let impl_candidates = Model.implementations role in - let rejects, feed_problems = Model.rejects role in + let* impl_candidates = Model.implementations role in + let+ rejects, feed_problems = Model.rejects role in let selected_commands = Results.selected_commands sel in Component.create ~role (impl_candidates, rejects, feed_problems) diagnostics impl selected_commands in - RoleMap.mapi get_selected impls + RoleMap.to_seq impls + |> Monad.Seq.parallel_map (fun (k, v) -> let+ v = get_selected k v in (k, v)) + >>| RoleMap.of_seq in process_root_req report root_req; examine_extra_restrictions report; @@ -434,6 +438,6 @@ module Make (Results : S.SOLVER_RESULT) = struct (** Return a message explaining why the solve failed. *) let get_failure_reason ?(verbose=false) result = - let reasons = of_result result in + let+ reasons = of_result result in Format.asprintf "Can't find all required implementations:@\n@[%a@]" (pp_rolemap ~verbose) reasons end diff --git a/vendor/0install-solver/src/solver/s.ml b/vendor/0install-solver/src/solver/s.ml index f37198f7479d..cb09f9104595 100644 --- a/vendor/0install-solver/src/solver/s.ml +++ b/vendor/0install-solver/src/solver/s.ml @@ -3,6 +3,28 @@ (** Some useful abstract module types. *) +module type Monad = sig + type 'a t + + val return : 'a -> 'a t + + module List : sig + val iter : ('a -> unit t) -> 'a list -> unit t + val iter2 : ('a -> 'b -> unit t) -> 'a list -> 'b list -> unit t + end + + module Seq : sig + val parallel_map : ('a -> 'b t) -> 'a Seq.t -> 'b Seq.t t + end + + module O : sig + val (>>|) : 'a t -> ('a -> 'b) -> 'b t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (let+) : 'a t -> ('a -> 'b) -> 'b t + val (let*) : 'a t -> ('a -> 'b t) -> 'b t + end +end + module type CORE_MODEL = sig (** To use the solver with a particular packaging system (e.g. 0install), you need to provide an implementation of this module to map your system's concepts on to @@ -77,6 +99,7 @@ module type CORE_MODEL = sig end module type SOLVER_INPUT = sig + type 'a monad (** This defines what the solver sees (hiding the raw XML, etc). *) include CORE_MODEL @@ -100,7 +123,7 @@ module type SOLVER_INPUT = sig val pp_command : Format.formatter -> command -> unit (** The list of candidates to fill a role. *) - val implementations : Role.t -> role_information + val implementations : Role.t -> role_information monad (** Restrictions on how the role is filled *) val restrictions : dependency -> restriction list @@ -120,7 +143,7 @@ module type SOLVER_INPUT = sig (** Get the candidates which were rejected for a role (and not passed to the solver), as well as any general notes and warnings not tied to a particular impl. *) - val rejects : Role.t -> (impl * rejection) list * string list + val rejects : Role.t -> ((impl * rejection) list * string list) monad (** Used to sort the results. *) val compare_version : impl -> impl -> int diff --git a/vendor/0install-solver/src/solver/solver_core.ml b/vendor/0install-solver/src/solver/solver_core.ml index 7ca1904d4624..2e138899a6e1 100644 --- a/vendor/0install-solver/src/solver/solver_core.ml +++ b/vendor/0install-solver/src/solver/solver_core.ml @@ -34,7 +34,7 @@ module type CACHE_ENTRY = sig val compare : t -> t -> int end -module Cache(CacheEntry : CACHE_ENTRY) : sig +module Cache (Monad : S.Monad)(CacheEntry : CACHE_ENTRY) : sig (** The cache is used in [build_problem], while the clauses are still being added. *) type t @@ -53,7 +53,7 @@ module Cache(CacheEntry : CACHE_ENTRY) : sig * but [process] can be. In other words, [make] does whatever setup *must* * be done before anyone can use this cache entry, while [process] does * setup that can be done afterwards. *) - val lookup : t -> (CacheEntry.t -> (CacheEntry.value * (unit -> unit))) -> CacheEntry.t -> CacheEntry.value + val lookup : t -> (CacheEntry.t -> (CacheEntry.value * (unit -> unit Monad.t)) Monad.t) -> CacheEntry.t -> CacheEntry.value Monad.t val snapshot : t -> snapshot val get : CacheEntry.t -> snapshot -> CacheEntry.value option @@ -69,12 +69,13 @@ end = struct let create () = ref M.empty let lookup table make key = + let open Monad.O in match M.find_opt key !table with - | Some x -> x + | Some x -> Monad.return x | None -> - let value, process = make key in + let* value, process = make key in table := M.add key value !table; - process (); + let+ () = process () in value let snapshot table = !table @@ -90,7 +91,10 @@ end = struct ) m M.empty end -module Make (Model : S.SOLVER_INPUT) = struct +module Make (Monad : S.Monad) (Model : S.SOLVER_INPUT with type 'a monad = 'a Monad.t) = struct + open Monad.O + type 'a monad = 'a Monad.t + (** We attach this data to each SAT variable. *) module SolverData = struct @@ -222,8 +226,8 @@ module Make (Model : S.SOLVER_INPUT) = struct type value = impl_candidates end - module ImplCache = Cache(RoleEntry) - module CommandCache = Cache(CommandRoleEntry) + module ImplCache = Cache(Monad)(RoleEntry) + module CommandCache = Cache(Monad)(CommandRoleEntry) module RoleMap = ImplCache.M @@ -331,7 +335,7 @@ module Make (Model : S.SOLVER_INPUT) = struct @param dep_iface the required interface this binding targets *) let process_self_command sat lookup_command user_var dep_role name = (* Note: we only call this for self-bindings, so we could be efficient by selecting the exact command here... *) - let candidates = lookup_command (name, dep_role) in + let+ candidates = lookup_command (name, dep_role) in S.implies sat ~reason:"binding on command" user_var candidates#get_vars (* Process a dependency of [user_var]: @@ -339,18 +343,19 @@ module Make (Model : S.SOLVER_INPUT) = struct - take just those that satisfy any restrictions in the dependency - ensure that we don't pick an incompatbile version if we select [user_var] - ensure that we do pick a compatible version if we select [user_var] (for "essential" dependencies only) *) - let process_dep sat lookup_impl lookup_command user_var dep = + let process_dep sat lookup_impl lookup_command user_var dep : unit Monad.t = let { Model.dep_role; dep_importance; dep_required_commands } = Model.dep_info dep in let dep_restrictions = Model.restrictions dep in (* Restrictions on the candidates *) let meets_restrictions impl = List.for_all (Model.meets_restriction impl) dep_restrictions in - let candidates = lookup_impl dep_role in + let* candidates = lookup_impl dep_role in let pass, fail = candidates#partition meets_restrictions in (* Dependencies on commands *) - dep_required_commands |> List.iter (fun name -> - let candidates = lookup_command (name, dep_role) in + let+ () = + dep_required_commands |> Monad.List.iter (fun name -> + let+ candidates = lookup_command (name, dep_role) in if dep_importance = `Essential then ( S.implies sat ~reason:"dep on command" user_var candidates#get_vars @@ -365,7 +370,7 @@ module Make (Model : S.SOLVER_INPUT) = struct * a suitable command. *) S.implies sat ~reason:"opt dep on command" user_var (S.neg dep_iface_selected :: candidates#get_vars) ); - ); + ) in if dep_importance = `Essential then ( S.implies sat ~reason:"essential dep" user_var pass (* Must choose a suitable candidate *) @@ -381,7 +386,7 @@ module Make (Model : S.SOLVER_INPUT) = struct (* Add the implementations of an interface to the ImplCache (called the first time we visit it). *) let make_impl_clause sat ~dummy_impl replacements role = - let {Model.replacement; impls} = Model.implementations role in + let+ {Model.replacement; impls} = Model.implementations role in (* Insert dummy_impl (last) if we're trying to diagnose a problem. *) let impls = @@ -407,7 +412,7 @@ module Make (Model : S.SOLVER_INPUT) = struct (* Create a new CommandCache entry (called the first time we request this key). *) let make_commands_clause sat lookup_impl process_self_commands process_deps key = let (command, role) = key in - let impls = lookup_impl role in + let+ impls = lookup_impl role in let commands = impls#get_commands command in let make_provides_command (_impl, elem) = (* [var] will be true iff this is selected. *) @@ -423,11 +428,11 @@ module Make (Model : S.SOLVER_INPUT) = struct S.implies sat ~reason:"impl for command" command_var [impl_var]; let deps, self_commands = Model.command_requires role command in (* Commands can depend on other commands in the same implementation *) - process_self_commands command_var role self_commands; + let* () = process_self_commands command_var role self_commands in (* Process command-specific dependencies *) process_deps command_var deps in - List.iter2 depend_on_impl vars commands + Monad.List.iter2 depend_on_impl vars commands ) (** Starting from [root_req], explore all the feeds, commands and implementations we might need, adding @@ -444,28 +449,30 @@ module Make (Model : S.SOLVER_INPUT) = struct let replacements = ref [] in let rec add_impls_to_cache role = - let clause, impls = make_impl_clause sat ~dummy_impl replacements role in + let+ clause, impls = make_impl_clause sat ~dummy_impl replacements role in (clause, fun () -> - impls |> List.iter (fun (impl_var, impl) -> + impls |> Monad.List.iter (fun (impl_var, impl) -> Machine_group.process machine_groups impl_var impl; Conflict_classes.process conflict_classes impl_var impl; let deps, self_commands = Model.requires role impl in - process_self_commands impl_var role self_commands; + let* () = process_self_commands impl_var role self_commands in process_deps impl_var deps ) ) and add_commands_to_cache key = make_commands_clause sat lookup_impl process_self_commands process_deps key and lookup_impl key = ImplCache.lookup impl_cache add_impls_to_cache key and lookup_command key = CommandCache.lookup command_cache add_commands_to_cache key - and process_self_commands user_var dep_role = List.iter (process_self_command sat lookup_command user_var dep_role) - and process_deps user_var = List.iter (process_dep sat lookup_impl lookup_command user_var) + and process_self_commands user_var dep_role = Monad.List.iter (process_self_command sat lookup_command user_var dep_role) + and process_deps user_var : _ -> unit Monad.t = Monad.List.iter (process_dep sat lookup_impl lookup_command user_var) in + let+ () = (* This recursively builds the whole problem up. *) begin match root_req with - | {Model.role; command = None} -> (lookup_impl role)#get_vars - | {Model.role; command = Some command} -> (lookup_command (command, role))#get_vars end - |> S.at_least_one sat ~reason:"need root"; (* Must get what we came for! *) + | {Model.role; command = None} -> let+ impl = (lookup_impl role) in impl#get_vars + | {Model.role; command = Some command} -> let+ command = (lookup_command (command, role)) in command#get_vars end + >>| S.at_least_one sat ~reason:"need root" (* Must get what we came for! *) + in (* All impl_candidates and command_candidates have now been added, so snapshot the cache. *) let impl_clauses, command_clauses = ImplCache.snapshot impl_cache, CommandCache.snapshot command_cache in @@ -538,7 +545,7 @@ module Make (Model : S.SOLVER_INPUT) = struct let sat = S.create () in let dummy_impl = if closest_match then Some Model.dummy_impl else None in - let impl_clauses, command_clauses = build_problem root_req sat ~dummy_impl in + let+ impl_clauses, command_clauses = build_problem root_req sat ~dummy_impl in let lookup = function | {Model.role; command = None} -> (ImplCache.get_exn role impl_clauses :> candidates) diff --git a/vendor/0install-solver/src/solver/zeroinstall_solver.mli b/vendor/0install-solver/src/solver/zeroinstall_solver.mli index 1ad0b1febc33..6c6136b6ec67 100644 --- a/vendor/0install-solver/src/solver/zeroinstall_solver.mli +++ b/vendor/0install-solver/src/solver/zeroinstall_solver.mli @@ -6,7 +6,7 @@ module S = S (** Select a compatible set of components to run a program. See [Zeroinstall.Solver] for the instantiation of this functor on the actual 0install types. *) -module Make(Input : S.SOLVER_INPUT) : sig +module Make(Monad : S.Monad)(Input : S.SOLVER_INPUT with type 'a monad = 'a Monad.t) : sig module Output : S.SOLVER_RESULT with module Input = Input (** [do_solve model req] finds an implementation matching the given requirements, plus any other implementations needed @@ -16,11 +16,11 @@ module Make(Input : S.SOLVER_INPUT) : sig You should ensure that [Input.get_command] always returns a dummy command for dummy_impl too. Note: always try without [closest_match] first, or it may miss a valid solution. @return None if the solve fails (only happens if [closest_match] is false). *) - val do_solve : closest_match:bool -> Input.requirements -> Output.t option + val do_solve : closest_match:bool -> Input.requirements -> Output.t option Monad.t end (** Explaining why a solve failed or gave an unexpected answer. *) -module Diagnostics(Result : S.SOLVER_RESULT) : sig +module Diagnostics(Monad : S.Monad)(Result : S.SOLVER_RESULT with type 'a Input.monad := 'a Monad.t) : sig (** An item of information to display for a component. *) module Note : sig @@ -81,13 +81,13 @@ module Diagnostics(Result : S.SOLVER_RESULT) : sig type t = Component.t Result.RoleMap.t (** An analysis of why the solve failed. *) - val of_result : Result.t -> t + val of_result : Result.t -> t Monad.t (** [of_result r] is an analysis of failed solver result [r]. We take the partial solution from the solver and discover, for each component we couldn't select, which constraints caused the candidates to be rejected. *) - val get_failure_reason : ?verbose:bool -> Result.t -> string + val get_failure_reason : ?verbose:bool -> Result.t -> string Monad.t (** [get_failure_reason r] analyses [r] with [of_result] and formats the analysis as a string. *) end diff --git a/vendor/opam-0install/lib/dir_context.ml b/vendor/opam-0install/lib/dir_context.ml index a8566c8ad5c1..e5bed36b7c4f 100644 --- a/vendor/opam-0install/lib/dir_context.ml +++ b/vendor/opam-0install/lib/dir_context.ml @@ -1,132 +1,138 @@ -type rejection = - | UserConstraint of OpamFormula.atom - | Unavailable - -let ( / ) = Filename.concat - -let with_dir path fn = - let ch = Unix.opendir path in - Fun.protect ~finally:(fun () -> Unix.closedir ch) (fun () -> fn ch) - -let list_dir path = - let rec aux acc ch = - match Unix.readdir ch with - | name -> aux (name :: acc) ch - | exception End_of_file -> acc - in - with_dir path (aux []) - -type t = - { env : string -> OpamVariable.variable_contents option - ; packages_dir : string - ; pins : (OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t - ; constraints : OpamFormula.version_constraint OpamTypes.name_map - (* User-provided constraints *) - ; test : OpamPackage.Name.Set.t - ; prefer_oldest : bool - } - -let load t pkg = - let { OpamPackage.name; version = _ } = pkg in - match OpamPackage.Name.Map.find_opt name t.pins with - | Some (_, opam) -> opam - | None -> - let opam_path = - t.packages_dir - / OpamPackage.Name.to_string name - / OpamPackage.to_string pkg / "opam" + +module Make (Monad : S.Monad) = struct + open Monad.O + + type rejection = + | UserConstraint of OpamFormula.atom + | Unavailable + + let ( / ) = Filename.concat + + let with_dir path fn = + let ch = Unix.opendir path in + Fun.protect ~finally:(fun () -> Unix.closedir ch) (fun () -> fn ch) + + let list_dir path = + let rec aux acc ch = + match Unix.readdir ch with + | name -> aux (name :: acc) ch + | exception End_of_file -> acc in - OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw opam_path)) - -let user_restrictions t name = OpamPackage.Name.Map.find_opt name t.constraints - -let dev = OpamPackage.Version.of_string "dev" - -let std_env ?(ocaml_native = true) ?sys_ocaml_version ?opam_version ~arch ~os - ~os_distribution ~os_family ~os_version () = function - | "arch" -> Some (OpamTypes.S arch) - | "os" -> Some (OpamTypes.S os) - | "os-distribution" -> Some (OpamTypes.S os_distribution) - | "os-version" -> Some (OpamTypes.S os_version) - | "os-family" -> Some (OpamTypes.S os_family) - | "opam-version" -> - Some - (OpamVariable.S - (Option.value ~default:OpamVersion.(to_string current) opam_version)) - | "sys-ocaml-version" -> - sys_ocaml_version |> Option.map (fun v -> OpamTypes.S v) - | "ocaml:native" -> Some (OpamTypes.B ocaml_native) - | "enable-ocaml-beta-repository" -> None (* Fake variable? *) - | v -> - OpamConsole.warning "Unknown variable %S" v; - None - -let env t pkg v = - if List.mem v OpamPackageVar.predefined_depends_variables then None - else - match OpamVariable.Full.to_string v with - | "version" -> + with_dir path (aux []) + + type t = + { env : string -> OpamVariable.variable_contents option + ; packages_dir : string + ; pins : (OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t + ; constraints : OpamFormula.version_constraint OpamTypes.name_map + (* User-provided constraints *) + ; test : OpamPackage.Name.Set.t + ; prefer_oldest : bool + } + + let load t pkg = + let { OpamPackage.name; version = _ } = pkg in + match OpamPackage.Name.Map.find_opt name t.pins with + | Some (_, opam) -> opam + | None -> + let opam_path = + t.packages_dir + / OpamPackage.Name.to_string name + / OpamPackage.to_string pkg / "opam" + in + OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw opam_path)) + + let user_restrictions t name = OpamPackage.Name.Map.find_opt name t.constraints + + let dev = OpamPackage.Version.of_string "dev" + + let std_env ?(ocaml_native = true) ?sys_ocaml_version ?opam_version ~arch ~os + ~os_distribution ~os_family ~os_version () = function + | "arch" -> Some (OpamTypes.S arch) + | "os" -> Some (OpamTypes.S os) + | "os-distribution" -> Some (OpamTypes.S os_distribution) + | "os-version" -> Some (OpamTypes.S os_version) + | "os-family" -> Some (OpamTypes.S os_family) + | "opam-version" -> Some - (OpamTypes.S (OpamPackage.Version.to_string (OpamPackage.version pkg))) - | x -> t.env x - -let filter_deps t pkg f = - let dev = OpamPackage.Version.compare (OpamPackage.version pkg) dev = 0 in - let test = OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in - f - |> OpamFilter.partial_filter_formula (env t pkg) - |> OpamFilter.filter_deps ~build:true ~post:true ~test ~doc:false ~dev - ~default:false - -let version_compare t v1 v2 = - if t.prefer_oldest then OpamPackage.Version.compare v1 v2 - else OpamPackage.Version.compare v2 v1 - -let candidates t name = - match OpamPackage.Name.Map.find_opt name t.pins with - | Some (version, opam) -> [ (version, Ok opam) ] - | None -> ( - let versions_dir = t.packages_dir / OpamPackage.Name.to_string name in - match list_dir versions_dir with - | versions -> - let user_constraints = user_restrictions t name in - versions - |> List.filter_map (fun dir -> - match OpamPackage.of_string_opt dir with - | Some pkg when Sys.file_exists (versions_dir / dir / "opam") -> - Some (OpamPackage.version pkg) - | _ -> None) - |> List.sort (version_compare t) - |> List.map (fun v -> - match user_constraints with - | Some test - when not - (OpamFormula.check_version_formula (OpamFormula.Atom test) - v) -> (v, Error (UserConstraint (name, Some test))) - | _ -> ( - let pkg = OpamPackage.create name v in - let opam = load t pkg in - let available = OpamFile.OPAM.available opam in - match - OpamFilter.eval ~default:(B false) (env t pkg) available - with - | B true -> (v, Ok opam) - | B false -> (v, Error Unavailable) - | _ -> - OpamConsole.error "Available expression not a boolean: %s" - (OpamFilter.to_string available); - (v, Error Unavailable))) - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> - OpamConsole.log "opam-0install" "Package %S not found!" - (OpamPackage.Name.to_string name); - []) - -let pp_rejection f = function - | UserConstraint x -> - Fmt.pf f "Rejected by user-specified constraint %s" - (OpamFormula.string_of_atom x) - | Unavailable -> Fmt.string f "Availability condition not satisfied" - -let create ?(prefer_oldest = false) ?(test = OpamPackage.Name.Set.empty) - ?(pins = OpamPackage.Name.Map.empty) ~constraints ~env packages_dir = - { env; packages_dir; pins; constraints; test; prefer_oldest } + (OpamVariable.S + (Option.value ~default:OpamVersion.(to_string current) opam_version)) + | "sys-ocaml-version" -> + sys_ocaml_version |> Option.map (fun v -> OpamTypes.S v) + | "ocaml:native" -> Some (OpamTypes.B ocaml_native) + | "enable-ocaml-beta-repository" -> None (* Fake variable? *) + | v -> + OpamConsole.warning "Unknown variable %S" v; + None + + let env t pkg v = + if List.mem v OpamPackageVar.predefined_depends_variables then None + else + match OpamVariable.Full.to_string v with + | "version" -> + Some + (OpamTypes.S (OpamPackage.Version.to_string (OpamPackage.version pkg))) + | x -> t.env x + + let filter_deps t pkg f = + let dev = OpamPackage.Version.compare (OpamPackage.version pkg) dev = 0 in + let test = OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in + f + |> OpamFilter.partial_filter_formula (env t pkg) + |> OpamFilter.filter_deps ~build:true ~post:true ~test ~doc:false ~dev + ~default:false + + let version_compare t v1 v2 = + if t.prefer_oldest then OpamPackage.Version.compare v1 v2 + else OpamPackage.Version.compare v2 v1 + + let candidates t name = + let+ () = Monad.return () in + match OpamPackage.Name.Map.find_opt name t.pins with + | Some (version, opam) -> [ (version, Ok opam) ] + | None -> ( + let versions_dir = t.packages_dir / OpamPackage.Name.to_string name in + match list_dir versions_dir with + | versions -> + let user_constraints = user_restrictions t name in + versions + |> List.filter_map (fun dir -> + match OpamPackage.of_string_opt dir with + | Some pkg when Sys.file_exists (versions_dir / dir / "opam") -> + Some (OpamPackage.version pkg) + | _ -> None) + |> List.sort (version_compare t) + |> List.map (fun v -> + match user_constraints with + | Some test + when not + (OpamFormula.check_version_formula (OpamFormula.Atom test) + v) -> (v, Error (UserConstraint (name, Some test))) + | _ -> ( + let pkg = OpamPackage.create name v in + let opam = load t pkg in + let available = OpamFile.OPAM.available opam in + match + OpamFilter.eval ~default:(B false) (env t pkg) available + with + | B true -> (v, Ok opam) + | B false -> (v, Error Unavailable) + | _ -> + OpamConsole.error "Available expression not a boolean: %s" + (OpamFilter.to_string available); + (v, Error Unavailable))) + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> + OpamConsole.log "opam-0install" "Package %S not found!" + (OpamPackage.Name.to_string name); + []) + + let pp_rejection f = function + | UserConstraint x -> + Fmt.pf f "Rejected by user-specified constraint %s" + (OpamFormula.string_of_atom x) + | Unavailable -> Fmt.string f "Availability condition not satisfied" + + let create ?(prefer_oldest = false) ?(test = OpamPackage.Name.Set.empty) + ?(pins = OpamPackage.Name.Map.empty) ~constraints ~env packages_dir = + { env; packages_dir; pins; constraints; test; prefer_oldest } +end diff --git a/vendor/opam-0install/lib/dir_context.mli b/vendor/opam-0install/lib/dir_context.mli index ebb7ec1efd81..6303a62ce4ea 100644 --- a/vendor/opam-0install/lib/dir_context.mli +++ b/vendor/opam-0install/lib/dir_context.mli @@ -3,7 +3,9 @@ It also does not get any opam variables from the environment - instead, the caller must provide them explicitly. *) -include S.CONTEXT +module Make (Monad : S.Monad) : sig + +include S.CONTEXT with type 'a monad := 'a Monad.t val std_env : ?ocaml_native:bool -> @@ -42,3 +44,4 @@ val create : up-to-date version of each package, if a solution exists. This is [false] by default. @before 0.4 the [prefer_oldest] parameter did not exist. *) +end diff --git a/vendor/opam-0install/lib/model.ml b/vendor/opam-0install/lib/model.ml index 8ae935f8ee08..152c3085e52d 100644 --- a/vendor/opam-0install/lib/model.ml +++ b/vendor/opam-0install/lib/model.ml @@ -1,6 +1,7 @@ (* Note: changes to this file may require similar changes to lib-cudf/model.ml *) -module Make (Context : S.CONTEXT) = struct +module Make (Monad : S.Monad) (Context : S.CONTEXT with type 'a monad = 'a Monad.t) = struct + type 'a monad = 'a Monad.t (* Note: [OpamFormula.neg] doesn't work in the [Empty] case, so we just record whether to negate the result here. *) type restriction = { @@ -64,6 +65,8 @@ module Make (Context : S.CONTEXT) = struct let role context name = Real { context; name } + open Monad.O + let fresh_id = let i = ref 0 in fun () -> @@ -172,12 +175,12 @@ module Make (Context : S.CONTEXT) = struct (* Get all the candidates for a role. *) let implementations = function - | Virtual (_, impls) -> { impls; replacement = None } + | Virtual (_, impls) -> Monad.return { impls; replacement = None } | Real role -> let context = role.context in - let impls = + let+ impls = Context.candidates context role.name - |> List.filter_map (function + >>| List.filter_map (function | _, Error _rejection -> None | version, Ok opam -> let pkg = OpamPackage.create role.name version in @@ -214,12 +217,12 @@ module Make (Context : S.CONTEXT) = struct let rejects role = match role with - | Virtual _ -> [], [] + | Virtual _ -> Monad.return ([], []) | Real role -> let context = role.context in - let rejects = + let+ rejects = Context.candidates context role.name - |> List.filter_map (function + >>| List.filter_map (function | _, Ok _ -> None | version, Error reason -> let pkg = OpamPackage.create role.name version in diff --git a/vendor/opam-0install/lib/model.mli b/vendor/opam-0install/lib/model.mli index 220493ca6c74..58f8aa5fac53 100644 --- a/vendor/opam-0install/lib/model.mli +++ b/vendor/opam-0install/lib/model.mli @@ -14,8 +14,8 @@ become a dependency on a virtual package which has each choice as an implementation. *) -module Make (Context : S.CONTEXT) : sig - include Zeroinstall_solver.S.SOLVER_INPUT with type rejection = Context.rejection +module Make (Monad : S.Monad) (Context : S.CONTEXT with type 'a monad = 'a Monad.t) : sig + include Zeroinstall_solver.S.SOLVER_INPUT with type rejection = Context.rejection and type 'a monad = 'a Monad.t val role : Context.t -> OpamPackage.Name.t -> Role.t diff --git a/vendor/opam-0install/lib/s.ml b/vendor/opam-0install/lib/s.ml index d97549005ddd..45e3344588fb 100644 --- a/vendor/opam-0install/lib/s.ml +++ b/vendor/opam-0install/lib/s.ml @@ -1,4 +1,8 @@ +module type Monad = Zeroinstall_solver.S.Monad + module type CONTEXT = sig + type 'a monad + type t type rejection @@ -7,7 +11,7 @@ module type CONTEXT = sig val pp_rejection : rejection Fmt.t - val candidates : t -> OpamPackage.Name.t -> (OpamPackage.Version.t * (OpamFile.OPAM.t, rejection) result) list + val candidates : t -> OpamPackage.Name.t -> (OpamPackage.Version.t * (OpamFile.OPAM.t, rejection) result) list monad (** [candidates t name] is the list of available versions of [name], in order of decreasing preference. If the user or environment provides additional constraints that mean a version should be rejected, include that here too. Rejects @@ -26,19 +30,21 @@ module type CONTEXT = sig end module type SOLVER = sig + type 'a monad + type t type selections type diagnostics - val solve : t -> OpamPackage.Name.t list -> (selections, diagnostics) result + val solve : t -> OpamPackage.Name.t list -> (selections, diagnostics) result monad (** [solve t package_names] finds a compatible set of package versions that includes all packages in [package_names] and their required dependencies. *) val packages_of_result : selections -> OpamPackage.t list - val diagnostics : ?verbose:bool -> diagnostics -> string + val diagnostics : ?verbose:bool -> diagnostics -> string monad (** [diagnostics d] is a message explaining why [d] failed, generated by performing another solve which doesn't abort on failure. *) end diff --git a/vendor/opam-0install/lib/solver.ml b/vendor/opam-0install/lib/solver.ml index 1d151bf77012..c38cf35e6c7a 100644 --- a/vendor/opam-0install/lib/solver.ml +++ b/vendor/opam-0install/lib/solver.ml @@ -1,5 +1,9 @@ -module Make(Context : S.CONTEXT) = struct - module Input = Model.Make(Context) +module Make(Monad : S.Monad)(Context : S.CONTEXT with type 'a monad = 'a Monad.t) = struct + open Monad.O + + type 'a monad = 'a Monad.t + + module Input = Model.Make(Monad)(Context) let version = Input.version let package_name = Input.package_name @@ -15,8 +19,8 @@ module Make(Context : S.CONTEXT) = struct in { Input.role; command = None } - module Solver = Zeroinstall_solver.Make(Input) - module Diagnostics = Zeroinstall_solver.Diagnostics(Solver.Output) + module Solver = Zeroinstall_solver.Make(Monad)(Input) + module Diagnostics = Zeroinstall_solver.Diagnostics(Monad)(Solver.Output) type t = Context.t type selections = Solver.Output.t @@ -24,7 +28,7 @@ module Make(Context : S.CONTEXT) = struct let solve context pkgs = let req = requirements ~context pkgs in - match Solver.do_solve ~closest_match:false req with + Solver.do_solve ~closest_match:false req >>| function | Some sels -> Ok sels | None -> Error req @@ -55,12 +59,12 @@ module Make(Context : S.CONTEXT) = struct let diagnostics_rolemap req = Solver.do_solve req ~closest_match:true - |> Option.get - |> Diagnostics.of_result + >>| Option.get + >>= Diagnostics.of_result let diagnostics ?(verbose=false) req = diagnostics_rolemap req - |> Fmt.str "Can't find all required versions.@\n@[%a@]" (pp_rolemap ~verbose) + >>| Fmt.str "Can't find all required versions.@\n@[%a@]" (pp_rolemap ~verbose) let packages_of_result sels = sels diff --git a/vendor/opam-0install/lib/solver.mli b/vendor/opam-0install/lib/solver.mli index 15dcc5faaf6d..c5e7d0feab8f 100644 --- a/vendor/opam-0install/lib/solver.mli +++ b/vendor/opam-0install/lib/solver.mli @@ -1,18 +1,18 @@ -module Make (C : S.CONTEXT) : sig - include S.SOLVER with type t = C.t +module Make (Monad : S.Monad) (C : S.CONTEXT with type 'a monad = 'a Monad.t) : sig + include S.SOLVER with type t = C.t and type 'a monad = 'a Monad.t - module Input : Zeroinstall_solver.S.SOLVER_INPUT with type rejection = C.rejection + module Input : Zeroinstall_solver.S.SOLVER_INPUT with type rejection = C.rejection and type 'a monad = 'a Monad.t module Solver : sig module Output : Zeroinstall_solver.S.SOLVER_RESULT with module Input = Input end module Diagnostics : sig - include module type of Zeroinstall_solver.Diagnostics(Solver.Output) + include module type of Zeroinstall_solver.Diagnostics(Monad)(Solver.Output) end val version : Input.impl -> OpamPackage.t option val package_name : Input.Role.t -> OpamPackage.Name.t option val formula : Input.restriction -> [`Ensure | `Prevent] * OpamFormula.version_formula - val diagnostics_rolemap : diagnostics -> Diagnostics.t + val diagnostics_rolemap : diagnostics -> Diagnostics.t Monad.t end diff --git a/vendor/opam-0install/lib/switch_context.ml b/vendor/opam-0install/lib/switch_context.ml index 42f39fb15cc7..96cc29195c56 100644 --- a/vendor/opam-0install/lib/switch_context.ml +++ b/vendor/opam-0install/lib/switch_context.ml @@ -1,63 +1,68 @@ -type rejection = UserConstraint of OpamFormula.atom - -type t = { - st : OpamStateTypes.unlocked OpamStateTypes.switch_state; (* To load the opam files *) - pkgs : OpamTypes.version_set OpamTypes.name_map; (* All available versions *) - constraints : OpamFormula.version_constraint OpamTypes.name_map; (* User-provided constraints *) - test : OpamPackage.Name.Set.t; - prefer_oldest : bool; -} - -let load t pkg = - try OpamSwitchState.opam t.st pkg - with Not_found -> - failwith (Format.asprintf "Package %S not found!" (OpamPackage.to_string pkg)) - -let user_restrictions t name = - OpamPackage.Name.Map.find_opt name t.constraints - -let env t pkg v = - if List.mem v OpamPackageVar.predefined_depends_variables then None - else ( - let r = OpamPackageVar.resolve_switch ~package:pkg t.st v in - if r = None then OpamConsole.warning "Unknown variable %S" (OpamVariable.Full.to_string v); - r - ) - -let filter_deps t pkg f = - let test = OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in - f - |> OpamFilter.partial_filter_formula (env t pkg) - |> OpamFilter.filter_deps ~build:true ~post:true ~test ~doc:false ~dev:false ~default:false - -let sort_versions t versions = - if t.prefer_oldest then - versions - else - List.rev versions - -let candidates t name = - let user_constraints = user_restrictions t name in - match OpamPackage.Name.Map.find_opt name t.pkgs with - | Some versions -> - OpamPackage.Version.Set.elements versions - |> sort_versions t (* Higher versions are preferred. *) - |> List.map (fun v -> - match user_constraints with - | Some test when not (OpamFormula.check_version_formula (OpamFormula.Atom test) v) -> - v, Error (UserConstraint (name, Some test)) - | _ -> - let opam = load t (OpamPackage.create name v) in - (* Note: [OpamStateTypes.available_packages] filters out unavailable packages for us. *) - v, Ok opam - ) - | None -> - OpamConsole.log "opam-0install" "Package %S not found!" (OpamPackage.Name.to_string name); - [] - -let pp_rejection f = function - | UserConstraint x -> Fmt.pf f "Rejected by user-specified constraint %s" (OpamFormula.string_of_atom x) - -let create ?(prefer_oldest=false) ?(test=OpamPackage.Name.Set.empty) ~constraints st = - let pkgs = Lazy.force st.OpamStateTypes.available_packages |> OpamPackage.to_map in - { st; pkgs; constraints; test; prefer_oldest } +module Make (Monad : S.Monad) = struct + open Monad.O + + type rejection = UserConstraint of OpamFormula.atom + + type t = { + st : OpamStateTypes.unlocked OpamStateTypes.switch_state; (* To load the opam files *) + pkgs : OpamTypes.version_set OpamTypes.name_map; (* All available versions *) + constraints : OpamFormula.version_constraint OpamTypes.name_map; (* User-provided constraints *) + test : OpamPackage.Name.Set.t; + prefer_oldest : bool; + } + + let load t pkg = + try OpamSwitchState.opam t.st pkg + with Not_found -> + failwith (Format.asprintf "Package %S not found!" (OpamPackage.to_string pkg)) + + let user_restrictions t name = + OpamPackage.Name.Map.find_opt name t.constraints + + let env t pkg v = + if List.mem v OpamPackageVar.predefined_depends_variables then None + else ( + let r = OpamPackageVar.resolve_switch ~package:pkg t.st v in + if r = None then OpamConsole.warning "Unknown variable %S" (OpamVariable.Full.to_string v); + r + ) + + let filter_deps t pkg f = + let test = OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in + f + |> OpamFilter.partial_filter_formula (env t pkg) + |> OpamFilter.filter_deps ~build:true ~post:true ~test ~doc:false ~dev:false ~default:false + + let sort_versions t versions = + if t.prefer_oldest then + versions + else + List.rev versions + + let candidates t name = + let+ () = Monad.return () in + let user_constraints = user_restrictions t name in + match OpamPackage.Name.Map.find_opt name t.pkgs with + | Some versions -> + OpamPackage.Version.Set.elements versions + |> sort_versions t (* Higher versions are preferred. *) + |> List.map (fun v -> + match user_constraints with + | Some test when not (OpamFormula.check_version_formula (OpamFormula.Atom test) v) -> + v, Error (UserConstraint (name, Some test)) + | _ -> + let opam = load t (OpamPackage.create name v) in + (* Note: [OpamStateTypes.available_packages] filters out unavailable packages for us. *) + v, Ok opam + ) + | None -> + OpamConsole.log "opam-0install" "Package %S not found!" (OpamPackage.Name.to_string name); + [] + + let pp_rejection f = function + | UserConstraint x -> Fmt.pf f "Rejected by user-specified constraint %s" (OpamFormula.string_of_atom x) + + let create ?(prefer_oldest=false) ?(test=OpamPackage.Name.Set.empty) ~constraints st = + let pkgs = Lazy.force st.OpamStateTypes.available_packages |> OpamPackage.to_map in + { st; pkgs; constraints; test; prefer_oldest } +end diff --git a/vendor/opam-0install/lib/switch_context.mli b/vendor/opam-0install/lib/switch_context.mli index d7fb2ac6c92b..27dec9a1f201 100644 --- a/vendor/opam-0install/lib/switch_context.mli +++ b/vendor/opam-0install/lib/switch_context.mli @@ -1,17 +1,19 @@ -include S.CONTEXT +module Make (Monad : S.Monad) : sig + include S.CONTEXT with type 'a monad := 'a Monad.t -val create : - ?prefer_oldest:bool -> - ?test:OpamPackage.Name.Set.t -> - constraints:OpamFormula.version_constraint OpamTypes.name_map -> - OpamStateTypes.unlocked OpamStateTypes.switch_state -> - t -(** [create ~constraints switch] is a solver that gets candidates from [switch], filtering them - using [constraints]. + val create : + ?prefer_oldest:bool -> + ?test:OpamPackage.Name.Set.t -> + constraints:OpamFormula.version_constraint OpamTypes.name_map -> + OpamStateTypes.unlocked OpamStateTypes.switch_state -> + t + (** [create ~constraints switch] is a solver that gets candidates from [switch], filtering them + using [constraints]. - @param test Packages for which we should include "with-test" dependencies. + @param test Packages for which we should include "with-test" dependencies. - @param prefer_oldest if [true] the solver is set to return the least - up-to-date version of each package, if a solution exists. This is [false] by - default. - @before 0.4 the [prefer_oldest] parameter did not exist. *) + @param prefer_oldest if [true] the solver is set to return the least + up-to-date version of each package, if a solution exists. This is [false] by + default. + @before 0.4 the [prefer_oldest] parameter did not exist. *) +end From afa34ed3b9dd37ed3991e7bfbe2afa12fa3af329 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 20 Oct 2023 11:24:49 -0600 Subject: [PATCH 02/20] feature(engine): allow customizing execution parameters per context (#8932) Signed-off-by: Rudi Grinberg --- src/dune_engine/build_config.ml | 2 +- src/dune_engine/build_config_intf.ml | 4 ++-- src/dune_engine/build_system.ml | 2 +- src/dune_rules/main.ml | 13 ++++++++----- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/dune_engine/build_config.ml b/src/dune_engine/build_config.ml index 2a33d63b4531..e5d636bb7cd4 100644 --- a/src/dune_engine/build_config.ml +++ b/src/dune_engine/build_config.ml @@ -77,7 +77,7 @@ type t = ; cache_config : Dune_cache.Config.t ; cache_debug_flags : Cache_debug_flags.t ; implicit_default_alias : Path.Build.t -> unit Action_builder.t option Memo.t - ; execution_parameters : dir:Path.Source.t -> Execution_parameters.t Memo.t + ; execution_parameters : dir:Path.Build.t -> Execution_parameters.t Memo.t ; source_tree : (module Source_tree) ; action_runner : Action_exec.input -> Action_runner.t option ; action_runners : unit -> Action_runner.t list diff --git a/src/dune_engine/build_config_intf.ml b/src/dune_engine/build_config_intf.ml index 883de499d967..f87d46b12829 100644 --- a/src/dune_engine/build_config_intf.ml +++ b/src/dune_engine/build_config_intf.ml @@ -136,7 +136,7 @@ module type Build_config = sig -> sandboxing_preference:Sandbox_mode.t list -> rule_generator:(module Gen_rules.Rule_generator) -> implicit_default_alias:(Path.Build.t -> unit Action_builder.t option Memo.t) - -> execution_parameters:(dir:Path.Source.t -> Execution_parameters.t Memo.t) + -> execution_parameters:(dir:Path.Build.t -> Execution_parameters.t Memo.t) -> source_tree:(module Source_tree) -> shared_cache:(module Shared_cache_intf.S) -> write_error_summary:(Build_system_error.Set.t -> unit Fiber.t) @@ -157,7 +157,7 @@ module type Build_config = sig ; cache_config : Dune_cache.Config.t ; cache_debug_flags : Cache_debug_flags.t ; implicit_default_alias : Path.Build.t -> unit Action_builder.t option Memo.t - ; execution_parameters : dir:Path.Source.t -> Execution_parameters.t Memo.t + ; execution_parameters : dir:Path.Build.t -> Execution_parameters.t Memo.t ; source_tree : (module Source_tree) ; action_runner : Action_exec.input -> Action_runner.t option ; action_runners : unit -> Action_runner.t list diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index d6d2a6027ab6..bc51b67c03fd 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -440,7 +440,7 @@ end = struct let head_target = Targets.Validated.head targets in let* execution_parameters = match Dpath.Target_dir.of_target dir with - | Regular (With_context (_, dir)) | Anonymous_action (With_context (_, dir)) -> + | Regular (With_context (_, _)) | Anonymous_action (With_context (_, _)) -> (Build_config.get ()).execution_parameters ~dir | Anonymous_action Root | Regular Root | Invalid _ -> Code_error.raise "invalid dir for rule execution" [ "dir", Path.Build.to_dyn dir ] diff --git a/src/dune_rules/main.ml b/src/dune_rules/main.ml index fe217ca61f19..90935aed80d8 100644 --- a/src/dune_rules/main.ml +++ b/src/dune_rules/main.ml @@ -26,15 +26,18 @@ let implicit_default_alias dir = let execution_parameters = let f path = - let open Memo.O in - let+ dir = Source_tree.nearest_dir path - and+ ep = Execution_parameters.default in - Dune_project.update_execution_parameters (Source_tree.Dir.project dir) ep + match Path.Build.drop_build_context path with + | None -> Dune_engine.Execution_parameters.default + | Some path -> + let open Memo.O in + let+ dir = Source_tree.nearest_dir path + and+ ep = Execution_parameters.default in + Dune_project.update_execution_parameters (Source_tree.Dir.project dir) ep in let memo = Memo.create "execution-parameters-of-dir" - ~input:(module Path.Source) + ~input:(module Path.Build) ~cutoff:Execution_parameters.equal f in From f6c4ad3388a83f91bced83d34d5cf832e343af04 Mon Sep 17 00:00:00 2001 From: Ali Caglayan Date: Fri, 20 Oct 2023 13:05:40 -0700 Subject: [PATCH 03/20] fix: add break hints to Dyn.pp (#8980) When working on another feature I noticed that Dyn.pp behaved very poorly when pretty printing variant contructor arguments. Turns out a Pp.char ',' seperator was being used however there was no break hint. This patch adds a Pp.space afterwards which seems to make the output much more pleasant. Signed-off-by: Ali Caglayan --- otherlibs/dyn/dyn.ml | 6 +- otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml | 12 +- otherlibs/stdune/test/ansi_color_tests.ml | 229 ++++++-------- .../dune_pkg/dune_pkg_unit_tests.ml | 12 +- .../dune_rpc_impl/dune_rpc_impl_tests.ml | 281 ++++++++---------- 5 files changed, 240 insertions(+), 300 deletions(-) diff --git a/otherlibs/dyn/dyn.ml b/otherlibs/dyn/dyn.ml index 3b35244d8f71..7031e10b52c6 100644 --- a/otherlibs/dyn/dyn.ml +++ b/otherlibs/dyn/dyn.ml @@ -112,7 +112,11 @@ let rec pp = | Variant (v, xs) -> Pp.hvbox ~indent:2 - (Pp.concat [ Pp.verbatim v; Pp.space; Pp.concat_map ~sep:(Pp.char ',') xs ~f:pp ]) + (Pp.concat + [ Pp.verbatim v + ; Pp.space + ; Pp.concat_map ~sep:(Pp.seq (Pp.char ',') Pp.space) xs ~f:pp + ]) ;; let to_string t = Format.asprintf "%a" Pp.to_fmt (pp t) diff --git a/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml b/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml index d6a514ac14a4..6c51501107d7 100644 --- a/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml +++ b/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml @@ -169,7 +169,7 @@ Error: Signature mismatch: [%expect {| >> error 0 - { loc = { path = "test.ml"; line = Range 3,5; chars = Some (6, 3) } + { loc = { path = "test.ml"; line = Range 3, 5; chars = Some (6, 3) } ; message = "Signature mismatch:\n\ Modules do not match:\n\ @@ -316,7 +316,7 @@ Error: Some record fields are undefined: signal_watcher >> error 0 { loc = { path = "test/expect-tests/timer_tests.ml" - ; line = Range 6,10 + ; line = Range 6, 10 ; chars = Some (2, 3) } ; message = "Some record fields are undefined: signal_watcher" @@ -573,7 +573,7 @@ Case >> error 0 { loc = { path = "src/dune_engine/action.ml" - ; line = Range 34,96 + ; line = Range 34, 96 ; chars = Some (4, 64) } ; message = @@ -586,7 +586,7 @@ Case >> error 1 { loc = { path = "src/dune_engine/action.ml" - ; line = Range 291,315 + ; line = Range 291, 315 ; chars = Some (2, 22) } ; message = @@ -599,7 +599,7 @@ Case >> error 2 { loc = { path = "src/dune_engine/action.ml" - ; line = Range 339,363 + ; line = Range 339, 363 ; chars = Some (21, 24) } ; message = @@ -612,7 +612,7 @@ Case >> error 3 { loc = { path = "src/dune_engine/action.ml" - ; line = Range 391,414 + ; line = Range 391, 414 ; chars = Some (4, 70) } ; message = diff --git a/otherlibs/stdune/test/ansi_color_tests.ml b/otherlibs/stdune/test/ansi_color_tests.ml index c61c343638b2..4e99445e9ca9 100644 --- a/otherlibs/stdune/test/ansi_color_tests.ml +++ b/otherlibs/stdune/test/ansi_color_tests.ml @@ -53,7 +53,9 @@ let%expect_test "reproduce #2664" = [%expect {| Vbox - 0,Seq + 0, + Seq + Seq Seq Seq Seq @@ -72,46 +74,27 @@ let%expect_test "reproduce #2664" = Seq Seq Seq - Seq - Nop,Tag [ Fg_blue ],Verbatim "1", - Tag - [ Fg_blue ],Verbatim "2", - Tag - [ Fg_blue ],Verbatim "3",Tag - [ Fg_blue - ], - Verbatim - "4", - Tag - [ Fg_blue ],Verbatim "5",Tag - [ Fg_blue ], - Verbatim - "6", - Tag - [ Fg_blue ],Verbatim "7",Tag - [ Fg_blue ], - Verbatim - "8",Tag - [ Fg_blue - ], - Verbatim - "9", - Tag - [ Fg_blue ],Verbatim "10",Tag - [ Fg_blue ],Verbatim - "11", - Tag - [ Fg_blue ],Verbatim "12",Tag - [ Fg_blue ],Verbatim "13", - Tag - [ Fg_blue ],Verbatim "14",Tag [ Fg_blue ],Verbatim "15", - Tag - [ Fg_blue ],Verbatim "16",Tag [ Fg_blue ],Verbatim "17", - Tag - [ Fg_blue ],Verbatim "18",Tag [ Fg_blue ],Verbatim "19",Tag - [ Fg_blue - ],Verbatim - "20" |}] + Nop, + Tag [ Fg_blue ], Verbatim "1", + Tag [ Fg_blue ], Verbatim "2", + Tag [ Fg_blue ], Verbatim "3", + Tag [ Fg_blue ], Verbatim "4", + Tag [ Fg_blue ], Verbatim "5", + Tag [ Fg_blue ], Verbatim "6", + Tag [ Fg_blue ], Verbatim "7", + Tag [ Fg_blue ], Verbatim "8", + Tag [ Fg_blue ], Verbatim "9", + Tag [ Fg_blue ], Verbatim "10", + Tag [ Fg_blue ], Verbatim "11", + Tag [ Fg_blue ], Verbatim "12", + Tag [ Fg_blue ], Verbatim "13", + Tag [ Fg_blue ], Verbatim "14", + Tag [ Fg_blue ], Verbatim "15", + Tag [ Fg_blue ], Verbatim "16", + Tag [ Fg_blue ], Verbatim "17", + Tag [ Fg_blue ], Verbatim "18", + Tag [ Fg_blue ], Verbatim "19", + Tag [ Fg_blue ], Verbatim "20" |}] ;; let%expect_test "Ansi_color.strip" = @@ -146,7 +129,9 @@ let%expect_test "parse fg and bg colors" = [%expect {| Vbox - 0,Seq + 0, + Seq + Seq Seq Seq Seq @@ -156,27 +141,18 @@ Vbox Seq Seq Seq - Seq - Seq Nop,Verbatim "This is a ",Tag - [ Fg_blue ], - Verbatim - "blue",Verbatim - " string with ", - Tag - [ Fg_red ],Verbatim "red",Verbatim " and ",Tag - [ Fg_green - ], - Verbatim - "green", - Verbatim - " together with strings of a ",Tag - [ Bg_blue ],Verbatim - "blue blackground", - Verbatim - " and ",Tag [ Bg_red ],Verbatim "red background",Verbatim - " and ", - Tag - [ Bg_green ],Verbatim "green background" |}] + Seq Nop, Verbatim "This is a ", + Tag [ Fg_blue ], Verbatim "blue", + Verbatim " string with ", + Tag [ Fg_red ], Verbatim "red", + Verbatim " and ", + Tag [ Fg_green ], Verbatim "green", + Verbatim " together with strings of a ", + Tag [ Bg_blue ], Verbatim "blue blackground", + Verbatim " and ", + Tag [ Bg_red ], Verbatim "red background", + Verbatim " and ", + Tag [ Bg_green ], Verbatim "green background" |}] ;; let%expect_test "parse multiple fg and bg colors" = @@ -191,16 +167,14 @@ let%expect_test "parse multiple fg and bg colors" = [%expect {| Vbox - 0,Seq + 0, + Seq + Seq Seq - Seq - Seq Nop,Verbatim "This text is ",Tag - [ Fg_blue; Bg_red ],Verbatim - "blue string with a red background", - Verbatim - " and ",Tag - [ Fg_green; Bg_blue ],Verbatim - "green string with a blue background" |}] + Seq Nop, Verbatim "This text is ", + Tag [ Fg_blue; Bg_red ], Verbatim "blue string with a red background", + Verbatim " and ", + Tag [ Fg_green; Bg_blue ], Verbatim "green string with a blue background" |}] ;; let%expect_test "fg default overrides" = @@ -215,15 +189,14 @@ let%expect_test "fg default overrides" = [%expect {| Vbox - 0,Seq + 0, + Seq + Seq Seq - Seq - Seq Nop,Verbatim "This text has a ",Tag - [ Fg_blue ],Verbatim - "blue foreground", - Verbatim - " but here it becomes the default foreground,",Verbatim - " even together with another foreground modifier." |}] + Seq Nop, Verbatim "This text has a ", + Tag [ Fg_blue ], Verbatim "blue foreground", + Verbatim " but here it becomes the default foreground,", + Verbatim " even together with another foreground modifier." |}] ;; let%expect_test "bg default overrides" = @@ -238,15 +211,14 @@ let%expect_test "bg default overrides" = [%expect {| Vbox - 0,Seq + 0, + Seq + Seq Seq - Seq - Seq Nop,Verbatim "This text has a ",Tag - [ Bg_blue ],Verbatim - "blue background", - Verbatim - " but here it becomes the default background,",Verbatim - " even together with another background modifier." |}] + Seq Nop, Verbatim "This text has a ", + Tag [ Bg_blue ], Verbatim "blue background", + Verbatim " but here it becomes the default background,", + Verbatim " even together with another background modifier." |}] ;; let%expect_test "parse 8-bit colors" = @@ -263,7 +235,9 @@ let%expect_test "parse 8-bit colors" = [%expect {| Vbox - 0,Seq + 0, + Seq + Seq Seq Seq Seq @@ -273,25 +247,18 @@ Vbox Seq Seq Seq - Seq - Seq Nop,Verbatim "This is a ",Tag - [ Fg_8_bit_color 33 - ],Verbatim "blue", - Verbatim - " string with ",Tag - [ Fg_8_bit_color 196 ],Verbatim - "red", - Verbatim - " and ",Tag [ Fg_8_bit_color 46 ],Verbatim "green", - Verbatim - " together with strings of a ",Tag - [ Bg_8_bit_color 33 ], - Verbatim - "blue blackground", - Verbatim - " and ",Tag [ Bg_8_bit_color 196 ],Verbatim "red background", - Verbatim - " and ",Tag [ Bg_8_bit_color 46 ],Verbatim "green background" |}] + Seq Nop, Verbatim "This is a ", + Tag [ Fg_8_bit_color 33 ], Verbatim "blue", + Verbatim " string with ", + Tag [ Fg_8_bit_color 196 ], Verbatim "red", + Verbatim " and ", + Tag [ Fg_8_bit_color 46 ], Verbatim "green", + Verbatim " together with strings of a ", + Tag [ Bg_8_bit_color 33 ], Verbatim "blue blackground", + Verbatim " and ", + Tag [ Bg_8_bit_color 196 ], Verbatim "red background", + Verbatim " and ", + Tag [ Bg_8_bit_color 46 ], Verbatim "green background" |}] ;; let%expect_test "parse 24-bit colors" = @@ -308,7 +275,9 @@ let%expect_test "parse 24-bit colors" = [%expect {| Vbox - 0,Seq + 0, + Seq + Seq Seq Seq Seq @@ -318,31 +287,21 @@ let%expect_test "parse 24-bit colors" = Seq Seq Seq - Seq - Seq Nop,Verbatim "This is a ",Tag - [ Fg_24_bit_color - [ 255; 0; 0 ] - ],Verbatim "blue", - Verbatim - " string with ",Tag - [ Fg_24_bit_color [ 0; 255; 0 ] ], - Verbatim - "red",Verbatim " and ", - Tag - [ Fg_24_bit_color [ 0; 0; 255 ] ],Verbatim "green", - Verbatim - " together with strings of a ",Tag - [ Bg_24_bit_color - [ 255; 0; 0 ] - ],Verbatim - "blue blackground", - Verbatim - " and ",Tag - [ Bg_24_bit_color [ 0; 255; 0 ] ],Verbatim - "red background", - Verbatim - " and ",Tag - [ Bg_24_bit_color [ 0; 0; 255 ] ],Verbatim - "green background" + Seq Nop, Verbatim "This is a ", + Tag + [ Fg_24_bit_color [ 255; 0; 0 ] ], + Verbatim "blue", + Verbatim " string with ", + Tag [ Fg_24_bit_color [ 0; 255; 0 ] ], Verbatim "red", + Verbatim " and ", + Tag [ Fg_24_bit_color [ 0; 0; 255 ] ], Verbatim "green", + Verbatim " together with strings of a ", + Tag + [ Bg_24_bit_color [ 255; 0; 0 ] ], + Verbatim "blue blackground", + Verbatim " and ", + Tag [ Bg_24_bit_color [ 0; 255; 0 ] ], Verbatim "red background", + Verbatim " and ", + Tag [ Bg_24_bit_color [ 0; 0; 255 ] ], Verbatim "green background" |}] ;; diff --git a/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml b/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml index 875413ef29a2..63648a3b8c00 100644 --- a/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml +++ b/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml @@ -202,7 +202,7 @@ let%expect_test "encode/decode round trip test for lockdir with complex deps" = ; source = Some External_copy External "/tmp/a" ; extra_sources = [ ("one", External_copy External "/tmp/a") - ; ("two", Fetch "randomurl",None) + ; ("two", Fetch "randomurl", None) ] } ; exported_env = [ { op = "="; var = "foo"; value = "bar" } ] @@ -218,8 +218,9 @@ let%expect_test "encode/decode round trip test for lockdir with complex deps" = ; source = Some Fetch - "https://github.com/foo/b",Some - "sha256=adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" + "https://github.com/foo/b", + Some + "sha256=adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" ; extra_sources = [] } ; exported_env = [] @@ -235,7 +236,7 @@ let%expect_test "encode/decode round trip test for lockdir with complex deps" = { name = "c" ; version = "0.2" ; dev = false - ; source = Some Fetch "https://github.com/foo/c",None + ; source = Some Fetch "https://github.com/foo/c", None ; extra_sources = [] } ; exported_env = [] @@ -247,7 +248,8 @@ let%expect_test "encode/decode round trip test for lockdir with complex deps" = ; used = Some [ opam_repo_serializable - Some Git_hash "95cf548dc","well-known-repo" + Some Git_hash "95cf548dc", + "well-known-repo" ] } } |}] diff --git a/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml b/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml index fb0426299eeb..83936e095403 100644 --- a/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml +++ b/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml @@ -51,31 +51,28 @@ let%expect_test "serialize and deserialize error message" = Error: Oh no! ---- Original ---- Vbox - 0,Seq - Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Seq - Tag Error,Verbatim "Error", - Char - : - ; Verbatim "Oh no!" - ],Break ("", 0, ""),("", 0, "") + 0, + Seq + Box + 0, + Concat + Break ("", 1, ""), ("", 0, ""), + [ Seq Tag Error, Verbatim "Error", Char :; Verbatim "Oh no!" ], + Break ("", 0, ""), ("", 0, "") ------- RPC ------ Vbox - 0,Seq - Box - 0,Vbox - 0,Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Seq - Tag - Error,Verbatim - "Error", - Char - : - ; Verbatim "Oh no!" - ],Break - ("", 0, ""),("", 0, "") |}] + 0, + Seq + Box + 0, + Vbox + 0, + Box + 0, + Concat + Break ("", 1, ""), ("", 0, ""), + [ Seq Tag Error, Verbatim "Error", Char :; Verbatim "Oh no!" ], + Break ("", 0, ""), ("", 0, "") |}] ;; let%expect_test "serialize and deserialize error message with location" = @@ -94,50 +91,44 @@ let%expect_test "serialize and deserialize error message with location" = Error: An error with location! ---- Original ---- Vbox - 0,Concat - Nop,[ Seq - Box 0,Tag Loc,Text "File \"Bar\", line 1, characters 2-3:", - Break - ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Seq - Tag - Error,Verbatim - "Error", - Char - : - ; Verbatim - "An error with location!" - ],Break - ("", 0, ""),("", 0, "") - ] + 0, + Concat + Nop, + [ Seq + Box 0, Tag Loc, Text "File \"Bar\", line 1, characters 2-3:", + Break ("", 0, ""), ("", 0, "") + ; Seq + Box + 0, + Concat + Break ("", 1, ""), ("", 0, ""), + [ Seq Tag Error, Verbatim "Error", Char : + ; Verbatim "An error with location!" + ], + Break ("", 0, ""), ("", 0, "") + ] ------- RPC ------ Vbox - 0,Concat - Nop,[ Seq - Box 0,Tag Loc,Text "File \"/Foo/Bar\", line 1, characters 2-3:", - Break - ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Vbox - 0,Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Seq - Tag - Error, - Verbatim - "Error", - Char - : - ; Verbatim - "An error with location!" - ],Break - ("", 0, ""), - ("", 0, "") - ] |}] + 0, + Concat + Nop, + [ Seq + Box 0, Tag Loc, Text "File \"/Foo/Bar\", line 1, characters 2-3:", + Break ("", 0, ""), ("", 0, "") + ; Seq + Box + 0, + Vbox + 0, + Box + 0, + Concat + Break ("", 1, ""), ("", 0, ""), + [ Seq Tag Error, Verbatim "Error", Char : + ; Verbatim "An error with location!" + ], + Break ("", 0, ""), ("", 0, "") + ] |}] ;; let%expect_test "serialize and deserialize error with location exerpt and hint" = @@ -167,94 +158,78 @@ let%expect_test "serialize and deserialize error with location exerpt and hint" Hint: Hint 2 ---- Original ---- Vbox - 0,Concat - Nop,[ Seq - Box 0,Tag Loc,Text "File \"foo.ml\", line 1, characters 2-3:", - Break - ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Seq - Tag - Error,Verbatim - "Error", - Char - : - ; Verbatim - "An error with location!" - ],Break - ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Seq - Seq - Tag Hint,Verbatim "Hint:",Break ("", 1, ""),("", 0, ""), - Verbatim - "Hint 1",Break ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Seq - Seq - Tag Hint,Verbatim "Hint:",Break ("", 1, ""),("", 0, ""), - Verbatim - "Hint 2",Break ("", 0, ""),("", 0, "") - ] + 0, + Concat + Nop, + [ Seq + Box 0, Tag Loc, Text "File \"foo.ml\", line 1, characters 2-3:", + Break ("", 0, ""), ("", 0, "") + ; Seq + Box + 0, + Concat + Break ("", 1, ""), ("", 0, ""), + [ Seq Tag Error, Verbatim "Error", Char : + ; Verbatim "An error with location!" + ], + Break ("", 0, ""), ("", 0, "") + ; Seq + Box + 0, + Seq + Seq Tag Hint, Verbatim "Hint:", Break ("", 1, ""), ("", 0, ""), + Verbatim "Hint 1", + Break ("", 0, ""), ("", 0, "") + ; Seq + Box + 0, + Seq + Seq Tag Hint, Verbatim "Hint:", Break ("", 1, ""), ("", 0, ""), + Verbatim "Hint 2", + Break ("", 0, ""), ("", 0, "") + ] ------- RPC ------ Vbox - 0,Concat - Nop,[ Seq - Box - 0,Tag - Loc,Text - "File \"TEST/foo.ml\", line 1, characters 2-3:", - Break - ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Vbox - 0,Concat - Break ("", 0, ""),("", 0, ""),[ Box - 0,Concat - Break - ("", 1, ""), - ("", 0, ""), - [ Seq - Tag - Error, - Verbatim - "Error", - Char - : - ; Verbatim - "An error with location!" - ] - ; Box - 0,Seq - Seq - Tag - Hint, - Verbatim - "Hint:", - Break - ("", 1, ""), - ("", 0, ""), - Verbatim - "Hint 1" - ; Box - 0,Seq - Seq - Tag - Hint, - Verbatim - "Hint:", - Break - ("", 1, ""), - ("", 0, ""), - Verbatim - "Hint 2" - ],Break - ("", 0, ""), - ("", 0, "") - ] |}] + 0, + Concat + Nop, + [ Seq + Box + 0, + Tag + Loc, + Text + "File \"TEST/foo.ml\", line 1, characters 2-3:", + Break ("", 0, ""), ("", 0, "") + ; Seq + Box + 0, + Vbox + 0, + Concat + Break ("", 0, ""), ("", 0, ""), + [ Box + 0, + Concat + Break ("", 1, ""), ("", 0, ""), + [ Seq Tag Error, Verbatim "Error", Char : + ; Verbatim "An error with location!" + ] + ; Box + 0, + Seq + Seq + Tag Hint, Verbatim "Hint:", + Break ("", 1, ""), ("", 0, ""), + Verbatim "Hint 1" + ; Box + 0, + Seq + Seq + Tag Hint, Verbatim "Hint:", + Break ("", 1, ""), ("", 0, ""), + Verbatim "Hint 2" + ], + Break ("", 0, ""), ("", 0, "") + ] |}] ;; From b0d4ea0e053b7828fbc81c23b3d82c8328df129a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 20 Oct 2023 18:53:19 -0600 Subject: [PATCH 04/20] test: better formatting (#8979) Signed-off-by: Rudi Grinberg --- .../test-cases/depend-on/dep-on-alias.t | 56 +++++++++---------- 1 file changed, 27 insertions(+), 29 deletions(-) diff --git a/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t b/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t index 3443409f05b9..65eaec3a44ad 100644 --- a/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t +++ b/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t @@ -9,18 +9,18 @@ $ echo old-contents > x $ cat >dune < (alias - > (name a) - > (deps x) - > ) + > (name a) + > (deps x)) > (rule - > (alias b) - > (deps (alias a)) - > (action (bash "echo -n \"running b: \"; cat x")) - > ) + > (alias b) + > (deps (alias a)) + > (action (system "printf \"running b: \"; cat x"))) > (rule - > (deps (alias a)) - > (action (progn (bash "echo -n \"running b: \"; cat x") (with-stdout-to b (bash "cat x")))) - > ) + > (deps (alias a)) + > (action + > (progn + > (system "printf \"running b: \"; cat x") + > (with-stdout-to b (system "cat x"))))) > EOF $ dune build @b running b: old-contents @@ -40,12 +40,11 @@ expanded when creating the sandbox: $ echo '(lang dune 2.8)' > dune-project $ dune clean $ dune build @b --sandbox copy 2>&1 | grep -v 'cd _build/.sandbox' - File "dune", line 5, characters 0-89: - 5 | (rule - 6 | (alias b) - 7 | (deps (alias a)) - 8 | (action (bash "echo -n \"running b: \"; cat x")) - 9 | ) + File "dune", line 4, characters 0-86: + 4 | (rule + 5 | (alias b) + 6 | (deps (alias a)) + 7 | (action (system "printf \"running b: \"; cat x"))) running b: cat: x: No such file or directory $ cat >dune-project < (lang dune 3.0) @@ -55,22 +54,21 @@ expanded when creating the sandbox: Now test that including an alias into another alias includes its expansion: $ cat >dune < (alias - > (name a0) - > (deps x) - > ) + > (name a0) + > (deps x)) > (alias - > (name a) - > (deps (alias a0)) - > ) + > (name a) + > (deps (alias a0))) > (rule - > (alias b) - > (deps (alias a)) - > (action (bash "echo -n \"running b: \"; cat x")) - > ) + > (alias b) + > (deps (alias a)) + > (action (system "printf \"running b: \"; cat x"))) > (rule - > (deps (alias a)) - > (action (progn (bash "echo -n \"running b: \"; cat x") (with-stdout-to b (bash "cat x")))) - > ) + > (deps (alias a)) + > (action + > (progn + > (system "printf \"running b: \"; cat x") + > (with-stdout-to b (system "cat x"))))) > EOF $ rm -r _build $ echo old-contents > x From 1386adf06a9b1502a16772f46590e9d7e53a9e13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Sun, 22 Oct 2023 08:47:14 +0200 Subject: [PATCH 05/20] Show dune cache location info in log (#8974) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Nicolás Ojeda Bär --- bin/common.ml | 5 +++++ doc/changes/8974.md | 1 + 2 files changed, 6 insertions(+) create mode 100644 doc/changes/8974.md diff --git a/bin/common.ml b/bin/common.ml index a4c3614aac15..abcd998ca88d 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -1249,6 +1249,11 @@ let init (builder : Builder.t) = } in Log.info [ Pp.textf "Shared cache: %s" (Config.Toggle.to_string config.cache_enabled) ]; + Log.info + [ Pp.textf + "Shared cache location: %s" + (Path.to_string Dune_cache_storage.Layout.root_dir) + ]; let action_runner = match builder.action_runner with | No -> None diff --git a/doc/changes/8974.md b/doc/changes/8974.md new file mode 100644 index 000000000000..8eee5a520226 --- /dev/null +++ b/doc/changes/8974.md @@ -0,0 +1 @@ +- Display cache location in Dune log (#8974, @nojb) From 8c91d664ac210323008f7f8159bf55ea18357999 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 22 Oct 2023 13:39:16 -0600 Subject: [PATCH 06/20] fix(pkg): require copying sandbox for build rules (#8923) Signed-off-by: Rudi Grinberg --- src/dune_rules/pkg_rules.ml | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index 734e5aab8733..72750d46412d 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -805,15 +805,18 @@ module Action_expander = struct } ;; - let expand context (pkg : Pkg.t) action = - let* expander = expander context pkg in - let+ action = - expand action ~expander >>| Action.chdir (Path.build pkg.paths.source_dir) - in - (* TODO copying is needed because patch/substitute might be present *) - Action.Full.make ~sandbox:Sandbox_config.needs_sandboxing action - |> Action_builder.return - |> Action_builder.with_no_targets + let expand = + let sandbox = Sandbox_mode.Set.singleton Sandbox_mode.copy in + fun context (pkg : Pkg.t) action -> + let+ action = + let* expander = expander context pkg in + expand action ~expander >>| Action.chdir (Path.build pkg.paths.source_dir) + in + (* TODO copying is needed for build systems that aren't dune and those + with an explicit install step *) + Action.Full.make ~sandbox action + |> Action_builder.return + |> Action_builder.with_no_targets ;; let build_command context (pkg : Pkg.t) = From a423c94411c94d330a5b96555f7375b6abb7052f Mon Sep 17 00:00:00 2001 From: pmwhite Date: Mon, 23 Oct 2023 09:07:49 -0400 Subject: [PATCH 07/20] Reduce allocations while loading rules (#8978) * engine chore: compute copy_rules after [rules_from_source_dir] The [copy_rules] field of this record is a bit out of place. It is easy to compute the copy_rules separately, so we should just do that. Also, this nicely sets up the next step of putting copy rules directly into the final list, rather than creating an intermediate list that later gets concatenated into the main one. Signed-off-by: Philip White * engine perf: avoid allocating intermediate list of rules Signed-off-by: Philip White * engine perf: avoid allocating record on each iteration of fold Signed-off-by: Philip White * tests: promote Previous commits changed the order in which rules are generated, which can affect the order things appear in error messages. This seems fine. Signed-off-by: Philip White * engine perf: replace refs with two accumulators and use better disjoint function These changes were made due to feedback from other folks. - Mutating refs is sometimes worse than allocating due to the write barrier. However, we can avoid both by maintaining to accumulators. - Some of the code was using a less efficient method of checking whether two sets are disjoint. Signed-off-by: Philip White * chore: add [disjoint] into the Set module It's a pretty generic function, so we might as well add it to Stdune Signed-off-by: Philip White * chore: improve module name Signed-off-by: Philip White --------- Signed-off-by: Philip White Co-authored-by: Philip White --- otherlibs/stdune/src/set.ml | 2 + otherlibs/stdune/src/set_intf.ml | 1 + src/dune_engine/load_rules.ml | 114 ++++++++---------- .../duplicate-target.t/run.t | 2 +- .../test-cases/github2061.t/run.t | 2 +- .../promote/dep-on-promoted-target.t | 2 +- .../test-cases/watching/target-promotion.t | 2 +- 7 files changed, 60 insertions(+), 65 deletions(-) diff --git a/otherlibs/stdune/src/set.ml b/otherlibs/stdune/src/set.ml index 9bbc6e03125f..d5c54f620a9d 100644 --- a/otherlibs/stdune/src/set.ml +++ b/otherlibs/stdune/src/set.ml @@ -21,6 +21,7 @@ module Make (Key : Map_intf.Key) (M : Map_intf.S with type key = Key.t) = struct let remove t x = remove x t let compare a b = Ordering.of_int (compare a b) let is_subset t ~of_ = subset t of_ + let are_disjoint a b = not (exists a ~f:(mem b)) let iter t ~f = iter t ~f let map t ~f = map t ~f let fold t ~init ~f = fold t ~init ~f @@ -102,6 +103,7 @@ module Of_map (Key : Map_intf.Key) (Map : Map_intf.S with type key = Key.t) = st | exception Not_a_subset -> false ;; + let are_disjoint a b = not (Map.existsi a ~f:(fun k () -> mem b k)) let iter t ~f = Map.iteri t ~f:(fun k () -> f k) let fold t ~init ~f = Map.foldi t ~init ~f:(fun k () acc -> f k acc) let map t ~f = fold t ~init:empty ~f:(fun x acc -> add acc (f x)) diff --git a/otherlibs/stdune/src/set_intf.ml b/otherlibs/stdune/src/set_intf.ml index b53aba55d754..6814055c5e44 100644 --- a/otherlibs/stdune/src/set_intf.ml +++ b/otherlibs/stdune/src/set_intf.ml @@ -15,6 +15,7 @@ module type S = sig val compare : t -> t -> Ordering.t val equal : t -> t -> bool val is_subset : t -> of_:t -> bool + val are_disjoint : t -> t -> bool val iter : t -> f:(elt -> unit) -> unit val map : t -> f:(elt -> elt) -> t val fold : t -> init:'a -> f:(elt -> 'a -> 'a) -> 'a diff --git a/src/dune_engine/load_rules.ml b/src/dune_engine/load_rules.ml index e858e74dc5b6..94df88686c9d 100644 --- a/src/dune_engine/load_rules.ml +++ b/src/dune_engine/load_rules.ml @@ -402,10 +402,10 @@ end = struct Appendable_list.to_list expansions) ;; - let filter_out_fallback_rules ~source_files rules = - List.filter rules ~f:(fun (rule : Rule.t) -> + let add_non_fallback_rules ~init ~source_files rules = + List.fold_left rules ~init ~f:(fun acc (rule : Rule.t) -> match rule.mode with - | Standard | Promote _ | Ignore_source_files -> true + | Standard | Promote _ | Ignore_source_files -> rule :: acc | Fallback -> let source_files_for_targets = if not (Path.Build.Set.is_empty rule.targets.dirs) @@ -422,11 +422,10 @@ end = struct in if Path.Source.Set.is_subset source_files_for_targets ~of_:source_files then (* All targets are present *) - false - else if Path.Source.Set.is_empty - (Path.Source.Set.inter source_files_for_targets source_files) + acc + else if Path.Source.Set.are_disjoint source_files_for_targets source_files then (* No target is present *) - true + rule :: acc else ( let absent_targets = Path.Source.Set.diff source_files_for_targets source_files @@ -668,10 +667,10 @@ end = struct (* Compute source paths ignored by specific rules *) let source_paths_to_ignore ~dir build_dir_only_sub_dirs rules = - List.fold_left - rules - ~init:{ files = Path.Build.Set.empty; dirnames = Filename.Set.empty } - ~f:(fun acc { Rule.targets; mode; loc; _ } -> + let rec iter ~files ~dirnames rules = + match rules with + | [] -> { files; dirnames } + | { Rule.targets; mode; loc; _ } :: rules -> let target_dirnames = lazy (Path.Build.Set.to_list_map ~f:Path.Build.basename targets.dirs @@ -688,47 +687,43 @@ end = struct | None -> () | Some target_name -> report_rule_internal_dir_conflict (Path.Build.basename target_name) loc); - match mode with - | Standard | Fallback -> acc - | Ignore_source_files -> - { files = Path.Build.Set.union acc.files targets.files - ; dirnames = Filename.Set.union acc.dirnames (Lazy.force target_dirnames) - } - | Promote { only; _ } -> - (* Note that the [only] predicate applies to the files inside the - directory targets rather than to directory names themselves. *) - let target_files = - match only with - | None -> targets.files - | Some pred -> - let is_promoted file = - Predicate.test pred (Path.reach (Path.build file) ~from:(Path.build dir)) - in - Path.Build.Set.filter targets.files ~f:is_promoted - in - { files = Path.Build.Set.union acc.files target_files - ; dirnames = Filename.Set.union acc.dirnames (Lazy.force target_dirnames) - }) + (match mode with + | Standard | Fallback -> iter ~files ~dirnames rules + | Ignore_source_files -> + iter + ~files:(Path.Build.Set.union files targets.files) + ~dirnames:(Filename.Set.union dirnames (Lazy.force target_dirnames)) + rules + | Promote { only; _ } -> + (* Note that the [only] predicate applies to the files inside the + directory targets rather than to directory names themselves. *) + let target_files = + match only with + | None -> targets.files + | Some pred -> + let is_promoted file = + Predicate.test pred (Path.reach (Path.build file) ~from:(Path.build dir)) + in + Path.Build.Set.filter targets.files ~f:is_promoted + in + iter + ~files:(Path.Build.Set.union files target_files) + ~dirnames:(Filename.Set.union dirnames (Lazy.force target_dirnames)) + rules) + in + iter ~files:Path.Build.Set.empty ~dirnames:Filename.Set.empty rules ;; - module Source_rules = struct + module Source_files_and_dirs = struct type t = { source_files : Path.Source.Set.t ; source_dirs : Filename.Set.t - ; copy_rules : Rule.t list } - let empty = - { source_files = Path.Source.Set.empty - ; source_dirs = Filename.Set.empty - ; copy_rules = [] - } - ;; + let empty = { source_files = Path.Source.Set.empty; source_dirs = Filename.Set.empty } end - (* Compute all the copying rules from the source directory. *) - let rules_from_source_dir source_paths_to_ignore (context_name : Context_name.t) sub_dir - = + let source_files_and_dirs source_paths_to_ignore sub_dir = (* Take into account the source files *) let+ source_files, source_dirs = let+ files, subdirs = @@ -751,11 +746,7 @@ end = struct files, subdirs in (* Compile the rules and cleanup stale artifacts *) - let copy_rules = - let ctx_dir = Context_name.build_dir context_name in - create_copy_rules ~ctx_dir ~non_target_source_files:source_files - in - { Source_rules.source_files; source_dirs; copy_rules } + { Source_files_and_dirs.source_files; source_dirs } ;; let descendants_to_keep @@ -873,27 +864,28 @@ end = struct (* Compute the set of sources and targets promoted to the source tree that must not be copied to the build directory. *) (* Take into account the source files *) - let* { Source_rules.source_files; source_dirs; copy_rules } = + let* { source_files; source_dirs } = match context_type with - | Empty -> Memo.return Source_rules.empty + | Empty -> Memo.return Source_files_and_dirs.empty | With_sources -> let source_paths_to_ignore = source_paths_to_ignore ~dir build_dir_only_sub_dirs rules in - rules_from_source_dir source_paths_to_ignore context_name sub_dir + source_files_and_dirs source_paths_to_ignore sub_dir + in + let copy_rules = + let ctx_dir = Context_name.build_dir context_name in + create_copy_rules ~ctx_dir ~non_target_source_files:source_files in (* Compile the rules and cleanup stale artifacts *) let rules = - let rules = - (* Filter out fallback rules *) - if Path.Source.Set.is_empty source_files - then - (* If there are no source files to copy, fallback rules are - automatically kept *) - rules - else filter_out_fallback_rules ~source_files rules - in - copy_rules @ rules + (* Filter out fallback rules *) + if Path.Source.Set.is_empty source_files + then + (* If there are no source files to copy, fallback rules are + automatically kept *) + rules + else add_non_fallback_rules ~init:copy_rules ~source_files rules in let* descendants_to_keep = descendants_to_keep build_dir build_dir_only_sub_dirs ~source_dirs rules_produced diff --git a/test/blackbox-tests/test-cases/directory-targets/duplicate-target.t/run.t b/test/blackbox-tests/test-cases/directory-targets/duplicate-target.t/run.t index 17509d430f97..16002593d763 100644 --- a/test/blackbox-tests/test-cases/directory-targets/duplicate-target.t/run.t +++ b/test/blackbox-tests/test-cases/directory-targets/duplicate-target.t/run.t @@ -2,6 +2,6 @@ Duplicate directory targets $ dune build Error: Multiple rules generated for _build/default/foo: - - dune:1 - dune:5 + - dune:1 [1] diff --git a/test/blackbox-tests/test-cases/github2061.t/run.t b/test/blackbox-tests/test-cases/github2061.t/run.t index 7667bfa21e41..939b1382801f 100644 --- a/test/blackbox-tests/test-cases/github2061.t/run.t +++ b/test/blackbox-tests/test-cases/github2061.t/run.t @@ -8,7 +8,7 @@ confusing than anything. $ echo '(lang dune 1.10)' > dune-project $ dune build a Error: Multiple rules generated for _build/default/a: - - file present in source tree - dune:1 + - file present in source tree Hint: rm -f a [1] diff --git a/test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t b/test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t index e1ffc1a1fc5a..f7747342219c 100644 --- a/test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t +++ b/test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t @@ -51,8 +51,8 @@ Now switch the mode to standard. Dune reports an error about multiple rules for $ dune build result Error: Multiple rules generated for _build/default/promoted: - - file present in source tree - dune:1 + - file present in source tree Hint: rm -f promoted [1] diff --git a/test/blackbox-tests/test-cases/watching/target-promotion.t b/test/blackbox-tests/test-cases/watching/target-promotion.t index d924637854d9..fb5441e046ee 100644 --- a/test/blackbox-tests/test-cases/watching/target-promotion.t +++ b/test/blackbox-tests/test-cases/watching/target-promotion.t @@ -139,8 +139,8 @@ We're done. Success, waiting for filesystem changes... Success, waiting for filesystem changes... Error: Multiple rules generated for _build/default/promoted: - - file present in source tree - dune:1 + - file present in source tree Hint: rm -f promoted Had 1 error, waiting for filesystem changes... Success, waiting for filesystem changes... From eb07022f12798374dd8d2b2420cbffbaee0b298f Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Mon, 23 Oct 2023 16:43:31 +0200 Subject: [PATCH 08/20] feat: record installed directories in dune-package (#8953) * feat: record installed directories in dune-package Fixes #8915 We add a `(dir PATH)` construct to the `(files)` field in `dune-package` files. It is used by `(package)` dependencies: they are expanded to the recursive contents of the installed directory. Signed-off-by: Etienne Millon --- doc/changes/package-dirs.md | 3 ++ src/dune_rules/dep_conf_eval.ml | 24 +++++++++++-- src/dune_rules/dune_package.ml | 36 +++++++++++++++---- src/dune_rules/dune_package.mli | 4 ++- src/dune_rules/install_rules.ml | 8 ++++- .../directory-targets/installed-dependency.t | 7 +--- 6 files changed, 64 insertions(+), 18 deletions(-) create mode 100644 doc/changes/package-dirs.md diff --git a/doc/changes/package-dirs.md b/doc/changes/package-dirs.md new file mode 100644 index 000000000000..230c5660bd81 --- /dev/null +++ b/doc/changes/package-dirs.md @@ -0,0 +1,3 @@ +- Mark installed directories in `dune-package` files. This fixes `(package)` + dependencies against packages that contain such directories. (#8953, fixes + #8915, @emillon) diff --git a/src/dune_rules/dep_conf_eval.ml b/src/dune_rules/dep_conf_eval.ml index 1c49e3fc26cd..8c340ec5984a 100644 --- a/src/dune_rules/dep_conf_eval.ml +++ b/src/dune_rules/dep_conf_eval.ml @@ -106,6 +106,21 @@ let add_sandbox_config acc (dep : Dep_conf.t) = | _ -> acc ;; +let rec dir_contents ~loc d = + match Path.Untracked.readdir_unsorted_with_kinds d with + | Error e -> Unix_error.Detailed.raise e + | Ok contents -> + List.concat_map contents ~f:(fun (entry, kind) -> + let path = Path.relative d entry in + match kind with + | S_REG -> [ path ] + | S_DIR -> dir_contents ~loc path + | _ -> + User_error.raise + ~loc + [ Pp.text "Encountered a special file while expanding dependency." ]) +;; + let rec dep expander : Dep_conf.t -> _ = function | Include s -> (* TODO this is wrong. we shouldn't allow bindings here if we are in an @@ -182,12 +197,12 @@ let rec dep expander : Dep_conf.t -> _ = function let version = Dune_project.dune_version @@ Scope.project @@ Expander.scope expander in + let loc = String_with_vars.loc p in if version < (2, 9) then Action_builder.fail { fail = (fun () -> - let loc = String_with_vars.loc p in User_error.raise ~loc [ Pp.textf @@ -200,8 +215,11 @@ let rec dep expander : Dep_conf.t -> _ = function List.concat_map ~f:(fun (s, l) -> let dir = Section.Map.find_exn pkg.sections s in - List.map l ~f:(fun d -> - Path.relative dir (Install.Entry.Dst.to_string d))) + List.concat_map l ~f:(fun (kind, d) -> + let path = Path.relative dir (Install.Entry.Dst.to_string d) in + match kind with + | `File -> [ path ] + | `Dir -> dir_contents ~loc path)) pkg.files in Action_builder.paths files) diff --git a/src/dune_rules/dune_package.ml b/src/dune_rules/dune_package.ml index 07cd91fa3790..78b8ac2371f9 100644 --- a/src/dune_rules/dune_package.ml +++ b/src/dune_rules/dune_package.ml @@ -357,6 +357,31 @@ module Entry = struct ;; end +type path = [ `File | `Dir ] * Install.Entry.Dst.t + +let decode_path = + let open Dune_lang.Decoder in + let* ast = peek_exn in + match ast with + | Atom _ -> + let+ f = Install.Entry.Dst.decode in + `File, f + | _ -> + fields + (let+ d = field "dir" Install.Entry.Dst.decode in + `Dir, d) +;; + +let encode_path = function + | `File, f -> Install.Entry.Dst.encode f + | `Dir, d -> Dune_lang.Encoder.constr "dir" Install.Entry.Dst.encode d +;; + +let path_to_dyn = function + | `File, f -> Install.Entry.Dst.to_dyn f + | `Dir, d -> Dyn.variant "dir" [ Install.Entry.Dst.to_dyn d ] +;; + type t = { name : Package.Name.t ; entries : Entry.t Lib_name.Map.t @@ -364,7 +389,7 @@ type t = ; sections : Path.t Section.Map.t ; sites : Section.t Site.Map.t ; dir : Path.t - ; files : (Section.t * Install.Entry.Dst.t list) list + ; files : (Section.t * path list) list } let decode ~lang ~dir = @@ -379,10 +404,7 @@ let decode ~lang ~dir = and+ sites = field ~default:[] "sites" (repeat (pair (located Site.decode) Section.decode)) and+ files = - field - ~default:[] - "files" - (repeat (pair Section.decode (enter (repeat Install.Entry.Dst.decode)))) + field ~default:[] "files" (repeat (pair Section.decode (enter (repeat decode_path)))) and+ entries = leftover_fields_as_sums (Entry.cstrs ~lang ~dir) in let entries = List.map entries ~f:(fun e -> @@ -442,7 +464,7 @@ let encode ~dune_version { entries; name; version; dir; sections; sites; files } (pair Section.encode (Dune_lang.Path.Local.encode ~dir)) (Section.Map.to_list sections) ; field_l "sites" (pair Site.encode Section.encode) sites - ; field_l "files" (pair Section.encode (list Install.Entry.Dst.encode)) files + ; field_l "files" (pair Section.encode (list encode_path)) files ] in let list s = Dune_lang.List s in @@ -471,7 +493,7 @@ let to_dyn { entries; name; version; dir; sections; sites; files } = ; "dir", Path.to_dyn dir ; "sections", Section.Map.to_dyn Path.to_dyn sections ; "sites", Site.Map.to_dyn Section.to_dyn sites - ; "files", (list (pair Section.to_dyn (list Install.Entry.Dst.to_dyn))) files + ; "files", (list (pair Section.to_dyn (list path_to_dyn))) files ] ;; diff --git a/src/dune_rules/dune_package.mli b/src/dune_rules/dune_package.mli index 6bd5c82e32c4..a1cd77f544ec 100644 --- a/src/dune_rules/dune_package.mli +++ b/src/dune_rules/dune_package.mli @@ -46,6 +46,8 @@ module Entry : sig val to_dyn : t Dyn.builder end +type path = [ `File | `Dir ] * Install.Entry.Dst.t + type t = { name : Package.Name.t ; entries : Entry.t Lib_name.Map.t @@ -53,7 +55,7 @@ type t = ; sections : Path.t Section.Map.t ; sites : Section.t Site.Map.t ; dir : Path.t - ; files : (Section.t * Install.Entry.Dst.t list) list + ; files : (Section.t * path list) list } val to_dyn : t Dyn.builder diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 060775af9d21..c5aa1c2b9bcf 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -676,7 +676,13 @@ end = struct let+ files = let+ map = Stanzas_to_entries.stanzas_to_entries sctx in Package.Name.Map.Multi.find map pkg_name - |> List.map ~f:(fun (e : Install.Entry.Sourced.t) -> e.entry.section, e.entry.dst) + |> List.map ~f:(fun (e : Install.Entry.Sourced.t) -> + let kind = + match e.entry.kind with + | `File -> `File + | `Directory | `Source_tree -> `Dir + in + e.entry.section, (kind, e.entry.dst)) |> Section.Map.of_list_multi |> Section.Map.to_list in diff --git a/test/blackbox-tests/test-cases/directory-targets/installed-dependency.t b/test/blackbox-tests/test-cases/directory-targets/installed-dependency.t index 771ece4141e7..d7bce9d44306 100644 --- a/test/blackbox-tests/test-cases/directory-targets/installed-dependency.t +++ b/test/blackbox-tests/test-cases/directory-targets/installed-dependency.t @@ -26,7 +26,7 @@ Allow directories to be installable (lang dune 3.11) (name foo) (sections (lib .) (share ../../share/foo)) - (files (lib (META dune-package)) (share (bar))) + (files (lib (META dune-package)) (share ((dir bar)))) $ dune install --root a --prefix $PWD/prefix --display short Installing $TESTCASE_ROOT/prefix/lib/foo/META Installing $TESTCASE_ROOT/prefix/lib/foo/dune-package @@ -45,9 +45,4 @@ Allow directories to be installable $ OCAMLPATH=$PWD/prefix/lib/:$OCAMLPATH dune build --root=b @foo --display=short Entering directory 'b' - Error: File unavailable: - $TESTCASE_ROOT/prefix/share/foo/bar - This is not a regular file (S_DIR) - -> required by alias foo in dune:1 Leaving directory 'b' - [1] From fce5a133d40bf64aeb20e45f191ff9d1a2690081 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 23 Oct 2023 11:36:00 -0600 Subject: [PATCH 09/20] fix(menhir): include_subdirs qualified (#8949) menhir stanzas wouldn't know how to attach themselves to executables or libraries with (include_subdirs qualified) because the module path wouldn't be computed. Now we compute the module path and it works. Signed-off-by: Rudi Grinberg --- doc/changes/8949.md | 2 ++ src/dune_rules/gen_rules.ml | 14 +++++++++- src/dune_rules/ml_sources.ml | 27 +++++++++++++------ src/dune_rules/ml_sources.mli | 5 +++- src/dune_rules/top_module.ml | 2 +- .../menhir/menhir-include-subdirs.t/run.t | 6 ----- 6 files changed, 39 insertions(+), 17 deletions(-) create mode 100644 doc/changes/8949.md diff --git a/doc/changes/8949.md b/doc/changes/8949.md new file mode 100644 index 000000000000..bde8b159c2e1 --- /dev/null +++ b/doc/changes/8949.md @@ -0,0 +1,2 @@ +- Correctly determine the stanza of menhir modules when `(include_subdirs + qualified)` is enabled (@rgrinberg, #8949, fixes #7610) diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index ebf9ae7a6cce..9e1fb6c20057 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -248,10 +248,22 @@ let gen_rules_for_stanzas | true -> let* ml_sources = Dir_contents.ocaml dir_contents in (match + let base_path = + match Ml_sources.include_subdirs ml_sources with + | Include Unqualified | No -> [] + | Include Qualified -> + Path.Local.descendant + (Path.Build.local ctx_dir) + ~of_:(Path.Build.local (Dir_contents.dir dir_contents)) + |> Option.value_exn + |> Path.Local.explode + |> List.map ~f:Module_name.of_string + in Menhir_rules.module_names m |> List.find_map ~f:(fun name -> let open Option.O in - let* origin = Ml_sources.find_origin ml_sources name in + let path = base_path @ [ name ] in + let* origin = Ml_sources.find_origin ml_sources path in List.find_map cctxs ~f:(fun (loc, cctx) -> Option.some_if (Loc.equal loc (Ml_sources.Origin.loc origin)) cctx)) with diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index aa886f6bf595..f8dec3ac139d 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -14,6 +14,12 @@ module Origin = struct | Executables e -> e.buildable.loc | Melange mel -> mel.loc ;; + + let to_dyn = function + | Library _ -> Dyn.variant "Library" [ Dyn.Opaque ] + | Executables _ -> Dyn.variant "Executables" [ Dyn.Opaque ] + | Melange _ -> Dyn.variant "Melange" [ Dyn.Opaque ] + ;; end module Modules = struct @@ -183,9 +189,18 @@ end type t = { modules : Modules.t ; artifacts : Artifacts.t Memo.Lazy.t + ; include_subdirs : Dune_file.Include_subdirs.t + } + +let include_subdirs t = t.include_subdirs + +let empty = + { modules = Modules.empty + ; artifacts = Memo.Lazy.of_val Artifacts.empty + ; include_subdirs = No } +;; -let empty = { modules = Modules.empty; artifacts = Memo.Lazy.of_val Artifacts.empty } let artifacts t = Memo.Lazy.force t.artifacts let modules_of_files ~path ~dialects ~dir ~files = @@ -195,7 +210,7 @@ let modules_of_files ~path ~dialects ~dir ~files = name, Module.File.make dialect (Path.relative dir fn) in let loc = Loc.in_dir dir in - String.Set.to_list files + Filename.Set.to_list files |> List.filter_partition_map ~f:(fun fn -> (* we aren't using Filename.extension because we want to handle filenames such as foo.cppo.ml *) @@ -265,11 +280,7 @@ let modules_and_obj_dir t ~for_ = ;; let modules t ~for_ = modules_and_obj_dir t ~for_ |> fst - -let find_origin (t : t) name = - (* TODO generalize to any path *) - Module_name.Path.Map.find t.modules.rev_map [ name ] -;; +let find_origin (t : t) path = Module_name.Path.Map.find t.modules.rev_map path let virtual_modules ~lookup_vlib vlib = let info = Lib.info vlib in @@ -565,5 +576,5 @@ let make ~libs:modules_of_stanzas.libraries ~exes:modules_of_stanzas.executables) in - { modules; artifacts } + { modules; artifacts; include_subdirs } ;; diff --git a/src/dune_rules/ml_sources.mli b/src/dune_rules/ml_sources.mli index 843e6158a233..fdb36850ab6f 100644 --- a/src/dune_rules/ml_sources.mli +++ b/src/dune_rules/ml_sources.mli @@ -12,6 +12,7 @@ module Origin : sig | Melange of Melange_stanzas.Emit.t val loc : t -> Loc.t + val to_dyn : t -> Dyn.t end module Artifacts : sig @@ -38,7 +39,7 @@ val modules_and_obj_dir : t -> for_:for_ -> Modules.t * Path.Build.t Obj_dir.t val modules : t -> for_:for_ -> Modules.t (** Find out the origin of the stanza for a given module *) -val find_origin : t -> Module_name.t -> Origin.t option +val find_origin : t -> Module_name.Path.t -> Origin.t option val empty : t @@ -49,6 +50,8 @@ val empty : t all virtual modules are implemented - make sure that we construct [Module.t] with the correct [kind] *) +val include_subdirs : t -> Dune_file.Include_subdirs.t + val make : Dune_file.t -> dir:Path.Build.t diff --git a/src/dune_rules/top_module.ml b/src/dune_rules/top_module.ml index abd4406f9e8f..6f5c013535df 100644 --- a/src/dune_rules/top_module.ml +++ b/src/dune_rules/top_module.ml @@ -33,7 +33,7 @@ let find_module sctx src = let* dir_contents = drop_rules @@ fun () -> Dir_contents.get sctx ~dir in let* ocaml = Dir_contents.ocaml dir_contents in let stanza = - match Ml_sources.find_origin ocaml module_name with + match Ml_sources.find_origin ocaml [ module_name ] with | Some (Executables exes) -> Some (`Executables exes) | Some (Library lib) -> Some (`Library lib) | None | Some (Melange _) -> None diff --git a/test/blackbox-tests/test-cases/menhir/menhir-include-subdirs.t/run.t b/test/blackbox-tests/test-cases/menhir/menhir-include-subdirs.t/run.t index d63009683411..11b1ca90ef2e 100644 --- a/test/blackbox-tests/test-cases/menhir/menhir-include-subdirs.t/run.t +++ b/test/blackbox-tests/test-cases/menhir/menhir-include-subdirs.t/run.t @@ -17,9 +17,3 @@ Menhir in other places than the root of the file hierarchy. Hint: Did you mean Baz? [1] $ test qualified - File "bar/dune", line 1, characters 0-23: - 1 | (menhir - 2 | (modules baz)) - Error: I can't determine what library/executable the files produced by this - stanza are part of. - [1] From e2374718b58781906dca9a2f5744254da8052f2d Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 23 Oct 2023 13:58:17 -0600 Subject: [PATCH 10/20] test(menhir): library interface (#8988) Signed-off-by: Rudi Grinberg --- .../test-cases/menhir/library-interface.t | 29 +++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 test/blackbox-tests/test-cases/menhir/library-interface.t diff --git a/test/blackbox-tests/test-cases/menhir/library-interface.t b/test/blackbox-tests/test-cases/menhir/library-interface.t new file mode 100644 index 000000000000..8805b2dfa320 --- /dev/null +++ b/test/blackbox-tests/test-cases/menhir/library-interface.t @@ -0,0 +1,29 @@ +We should be able to use menhir as a library interface: + + $ cat >dune-project < (lang dune 3.11) + > (using menhir 2.1) + > EOF + + $ cat >dune < (include_subdirs qualified) + > (library (name foo)) + > (menhir (modules foo)) + > EOF + + $ touch m.ml + + $ cat >foo.mly < %{ + > module M = M + > %} + > %token EOF + > + > %start unit + > %% + > + > unit: + > | EOF { () } + > EOF + + $ dune build foo.cma From 160b72ed9eeb8851ade631dca39958b19d1def13 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 23 Oct 2023 13:59:35 -0600 Subject: [PATCH 11/20] test(menhir): using a menhir module as a group interface (#8987) Signed-off-by: Rudi Grinberg --- .../menhir/include-subdirs-group-interface.t | 37 +++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 test/blackbox-tests/test-cases/menhir/include-subdirs-group-interface.t diff --git a/test/blackbox-tests/test-cases/menhir/include-subdirs-group-interface.t b/test/blackbox-tests/test-cases/menhir/include-subdirs-group-interface.t new file mode 100644 index 000000000000..940b1faa5591 --- /dev/null +++ b/test/blackbox-tests/test-cases/menhir/include-subdirs-group-interface.t @@ -0,0 +1,37 @@ +We should be able to use menhir as a group interface: + + $ cat >dune-project < (lang dune 3.11) + > (using menhir 2.1) + > EOF + + $ cat >dune < (include_subdirs qualified) + > (executable (name foo)) + > EOF + $ touch foo.ml + + $ mkdir group + $ cat >group/dune < (menhir (modules group)) + > EOF + + $ cat >group/group.mly < %{ + > module M = M + > %} + > %token EOF + > + > %start unit + > %% + > + > unit: + > | EOF { () } + > EOF + + $ touch group/m.ml + + $ dune build + File "group/group.mly", line 2, characters 11-12: + Error: Unbound module M + [1] From 7c82d3ed197456ef3f9f89e16f0d29a17f4d6211 Mon Sep 17 00:00:00 2001 From: Stephen Sherratt Date: Tue, 24 Oct 2023 11:46:49 +1100 Subject: [PATCH 12/20] (pkg) refactor solver fields in workspace config (#8935) Removes the `solver_env` section of the workspace config and replaces it with the individual fields of `solver_env` that can be set from there. Also the "repositories" field of `Solver_env.t` is removed so that that type just contains the variable environment used by the solver. Signed-off-by: Stephen Sherratt --- bin/pkg.ml | 82 ++++++++++--------- src/dune_pkg/solver_env.ml | 39 ++------- src/dune_pkg/solver_env.mli | 7 +- src/dune_rules/context.ml | 3 +- src/dune_rules/workspace.ml | 39 +++++++-- src/dune_rules/workspace.mli | 3 +- .../pkg/env-conditional-dependencies.t | 10 +-- .../test-cases/pkg/just-print-solver-env.t | 24 ++---- .../test-cases/pkg/multiple-opam-repos.t | 12 +-- .../test-cases/pkg/opam-repository-download.t | 3 +- .../test-cases/pkg/unavailable-packages.t | 10 +-- 11 files changed, 112 insertions(+), 120 deletions(-) diff --git a/bin/pkg.ml b/bin/pkg.ml index db546caa98d4..722d4cf47d29 100644 --- a/bin/pkg.ml +++ b/bin/pkg.ml @@ -39,7 +39,8 @@ module Per_context = struct type t = { lock_dir_path : Path.Source.t ; version_preference : Version_preference.t - ; solver_env : Dune_pkg.Solver_env.t + ; solver_sys_vars : Dune_pkg.Solver_env.Variable.Sys.Bindings.t option + ; repositories : Dune_pkg.Pkg_workspace.Repository.Name.t list ; context_common : Dune_rules.Workspace.Context.Common.t ; repos : Dune_pkg.Pkg_workspace.Repository.t Dune_pkg.Pkg_workspace.Repository.Name.Map.t @@ -77,7 +78,8 @@ module Per_context = struct (Default { lock ; version_preference = version_preference_context - ; solver_env + ; solver_sys_vars + ; repositories ; base = context_common ; _ }) -> @@ -86,7 +88,8 @@ module Per_context = struct Version_preference.choose ~from_arg:version_preference_arg ~from_context:version_preference_context - ; solver_env = Option.value solver_env ~default:Dune_pkg.Solver_env.default + ; solver_sys_vars + ; repositories ; context_common ; repos = repositories_of_workspace workspace } @@ -104,7 +107,8 @@ module Per_context = struct { lock ; version_preference = version_preference_context ; base = context_common - ; solver_env + ; solver_sys_vars + ; repositories } -> let lock_dir_path = Option.value lock ~default:Dune_pkg.Lock_dir.default_path in Some @@ -114,7 +118,8 @@ module Per_context = struct ~from_arg:version_preference_arg ~from_context:version_preference_context ; context_common - ; solver_env = Option.value solver_env ~default:Dune_pkg.Solver_env.default + ; solver_sys_vars + ; repositories ; repos = repositories_of_workspace workspace } | Opam _ -> None) @@ -149,31 +154,31 @@ module Per_context = struct ;; end -module Print_solver_env = struct - (* The system environment variables used by the solver are taken from the - current system by default but can be overridden by the build context. *) - let override_solver_env_variables - ~solver_env_from_context - ~sys_bindings_from_current_system - = - Dune_pkg.Solver_env.( - Variable.Sys.Bindings.extend - sys_bindings_from_current_system - (sys solver_env_from_context) - |> set_sys solver_env_from_context) - ;; +(* The system environment variables used by the solver are taken from the + current system by default but can be overridden by the build context. *) +let solver_env_variables ~solver_sys_vars_from_context ~sys_bindings_from_current_system = + match solver_sys_vars_from_context with + | None -> sys_bindings_from_current_system + | Some solver_env_variables -> + Dune_pkg.Solver_env.Variable.Sys.Bindings.extend + sys_bindings_from_current_system + solver_env_variables +;; +module Print_solver_env = struct let print_solver_env_for_one_context ~sys_bindings_from_current_system - { Per_context.solver_env = solver_env_from_context + { Per_context.solver_sys_vars = solver_sys_vars_from_context ; context_common = { name = context_name; _ } ; _ } = let solver_env = - override_solver_env_variables - ~solver_env_from_context - ~sys_bindings_from_current_system + Dune_pkg.Solver_env.create + ~sys: + (solver_env_variables + ~solver_sys_vars_from_context + ~sys_bindings_from_current_system) in Console.print [ Pp.textf @@ -302,7 +307,7 @@ module Lock = struct ;; end - let get_repos repos solver_env ~opam_repository_path ~opam_repository_url = + let get_repos repos ~opam_repository_path ~opam_repository_url ~repositories = let open Fiber.O in match opam_repository_path, opam_repository_url with | Some _, Some _ -> @@ -325,8 +330,7 @@ module Lock = struct User_error.raise [ Pp.text "Can't determine the location of the opam-repository" ]) | None, None -> - (* read from workspace *) - Dune_pkg.Solver_env.repos solver_env + repositories |> Fiber.parallel_map ~f:(fun name -> match Dune_pkg.Pkg_workspace.Repository.Name.Map.find repos name with | None -> @@ -399,17 +403,20 @@ module Lock = struct { Per_context.lock_dir_path ; version_preference ; repos - ; solver_env = solver_env_from_context + ; solver_sys_vars = solver_sys_vars_from_context ; context_common = { name = context_name; _ } + ; repositories } -> let solver_env = - Print_solver_env.override_solver_env_variables - ~solver_env_from_context - ~sys_bindings_from_current_system + Dune_pkg.Solver_env.create + ~sys: + (solver_env_variables + ~solver_sys_vars_from_context + ~sys_bindings_from_current_system) in let* repos = - get_repos repos solver_env ~opam_repository_path ~opam_repository_url + get_repos repos ~opam_repository_path ~opam_repository_url ~repositories in let overlay = Console.Status_line.add_overlay (Constant (Pp.text "Solving for Build Plan")) @@ -569,18 +576,17 @@ module Outdated = struct { Per_context.lock_dir_path ; version_preference = _ ; repos - ; solver_env = solver_env_from_context + ; solver_sys_vars = _ ; context_common = _ + ; repositories } -> - let solver_env = - Print_solver_env.override_solver_env_variables - ~solver_env_from_context - ~sys_bindings_from_current_system: - Dune_pkg.Solver_env.Variable.Sys.Bindings.empty - in let+ repos = - Lock.get_repos repos solver_env ~opam_repository_path ~opam_repository_url + Lock.get_repos + repos + ~opam_repository_path + ~opam_repository_url + ~repositories and+ local_packages = Lock.find_local_packages in let lock_dir = Lock_dir.read_disk lock_dir_path in let results = diff --git a/src/dune_pkg/solver_env.ml b/src/dune_pkg/solver_env.ml index 92de377daad5..d39adbb2e150 100644 --- a/src/dune_pkg/solver_env.ml +++ b/src/dune_pkg/solver_env.ml @@ -127,58 +127,38 @@ end type t = { sys : Variable.Sys.Bindings.t ; const : Variable.Const.Bindings.t - ; repos : Workspace.Repository.Name.t list } module Fields = struct let sys = "sys" let const = "const" - let repos = "repositories" end -let default = - { sys = Variable.Sys.Bindings.empty - ; const = Variable.Const.bindings - ; repos = [ Workspace.Repository.Name.of_string "default" ] - } -;; - -let repos_of_ordered_set ordered_set = - Dune_lang.Ordered_set_lang.eval - ordered_set - ~parse:(fun ~loc string -> Workspace.Repository.Name.parse_string_exn (loc, string)) - ~eq:Workspace.Repository.Name.equal - ~standard:default.repos -;; +let create ~sys = { sys; const = Variable.Const.bindings } +let default = create ~sys:Variable.Sys.Bindings.empty let decode = let open Decoder in fields @@ - let+ sys = field Fields.sys ~default:default.sys Variable.Sys.Bindings.decode - and+ repos = Dune_lang.Ordered_set_lang.field Fields.repos in + let+ sys = field Fields.sys ~default:default.sys Variable.Sys.Bindings.decode in let const = default.const in - let repos = repos_of_ordered_set repos in - { sys; const; repos } + { sys; const } ;; -let to_dyn { sys; const; repos } = +let to_dyn { sys; const } = Dyn.record [ Fields.sys, Variable.Sys.Bindings.to_dyn sys ; Fields.const, Variable.Const.Bindings.to_dyn const - ; Fields.repos, Dyn.list Workspace.Repository.Name.to_dyn repos ] ;; -let equal { sys; const; repos } t = - Variable.Sys.Bindings.equal sys t.sys - && Variable.Const.Bindings.equal const t.const - && List.equal Workspace.Repository.Name.equal repos t.repos +let equal { sys; const } t = + Variable.Sys.Bindings.equal sys t.sys && Variable.Const.Bindings.equal const t.const ;; let sys { sys; _ } = sys let set_sys t sys = { t with sys } -let repos { repos; _ } = repos let pp = let pp_section heading pp_section = @@ -186,14 +166,11 @@ let pp = let pp_heading = Pp.hbox (Pp.text heading) in Pp.concat ~sep:Pp.space [ pp_heading; pp_section ] |> Pp.vbox in - fun { sys; const; repos } -> + fun { sys; const } -> Pp.enumerate ~f:Fun.id [ pp_section "System Environment Variables" (Variable.Sys.Bindings.pp sys) ; pp_section "Constants" (Variable.Const.Bindings.pp const) - ; pp_section - "Repositories" - (Pp.chain repos ~f:(fun r -> Workspace.Repository.Name.pp r)) ] ;; diff --git a/src/dune_pkg/solver_env.mli b/src/dune_pkg/solver_env.mli index fc5b40a85267..36393f13c395 100644 --- a/src/dune_pkg/solver_env.mli +++ b/src/dune_pkg/solver_env.mli @@ -25,6 +25,9 @@ module Variable : sig (** A mapping from system environment variables to their values *) type t + val to_dyn : t -> Dyn.t + val decode : t Dune_sexp.Decoder.t + val equal : t -> t -> bool val empty : t val set : t -> sys_var -> string -> t val get : t -> sys_var -> string option @@ -57,6 +60,7 @@ end environment as dune does not give users access to those variables.. *) type t +val create : sys:Variable.Sys.Bindings.t -> t val default : t val decode : t Dune_sexp.Decoder.t val to_dyn : t -> Dyn.t @@ -64,9 +68,6 @@ val equal : t -> t -> bool val sys : t -> Variable.Sys.Bindings.t val set_sys : t -> Variable.Sys.Bindings.t -> t -(** [repos t] returns the selected repository names in priority order *) -val repos : t -> Workspace.Repository.Name.t list - (** A human-readible summary of the variable environment *) val pp : t -> 'a Pp.t diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml index d811c1cdecf1..73ec7e379801 100644 --- a/src/dune_rules/context.ml +++ b/src/dune_rules/context.ml @@ -584,7 +584,8 @@ module Group = struct match context with | Opam { base; switch } -> create_for_opam builder ~switch ~loc:base.loc ~targets:base.targets - | Default { lock; version_preference = _; solver_env = _; base } -> + | Default + { lock; version_preference = _; solver_sys_vars = _; repositories = _; base } -> let builder = match builder.findlib_toolchain with | Some _ -> builder diff --git a/src/dune_rules/workspace.ml b/src/dune_rules/workspace.ml index ec0fa4965505..d60f5afb89f0 100644 --- a/src/dune_rules/workspace.ml +++ b/src/dune_rules/workspace.ml @@ -279,20 +279,32 @@ module Context = struct { base : Common.t ; lock : Path.Source.t option ; version_preference : Dune_pkg.Version_preference.t option - ; solver_env : Dune_pkg.Solver_env.t option + ; solver_sys_vars : Dune_pkg.Solver_env.Variable.Sys.Bindings.t option + ; repositories : Dune_pkg.Pkg_workspace.Repository.Name.t list } - let to_dyn { base; lock; version_preference; solver_env } = + let to_dyn { base; lock; version_preference; solver_sys_vars; repositories } = Dyn.record [ "base", Common.to_dyn base ; "lock", Dyn.(option Path.Source.to_dyn) lock ; ( "version_preference" , Dyn.option Dune_pkg.Version_preference.to_dyn version_preference ) - ; "solver_env", Dyn.option Dune_pkg.Solver_env.to_dyn solver_env + ; ( "solver_sys_vars" + , Dyn.option Dune_pkg.Solver_env.Variable.Sys.Bindings.to_dyn solver_sys_vars ) + ; ( "repositories" + , Dyn.list Dune_pkg.Pkg_workspace.Repository.Name.to_dyn repositories ) ] ;; let decode = + let repositories_of_ordered_set ordered_set = + Dune_lang.Ordered_set_lang.eval + ordered_set + ~parse:(fun ~loc string -> + Dune_pkg.Pkg_workspace.Repository.Name.parse_string_exn (loc, string)) + ~eq:Dune_pkg.Pkg_workspace.Repository.Name.equal + ~standard:[ Dune_pkg.Pkg_workspace.Repository.Name.of_string "default" ] + in let+ common = Common.decode and+ name = field_o "name" (Dune_lang.Syntax.since syntax (1, 10) >>> Context_name.decode) @@ -304,7 +316,10 @@ module Context = struct field_o "lock" (Dune_lang.Path.Local.decode ~dir:(Path.source Path.Source.root)) and+ version_preference = field_o "version_preference" Dune_pkg.Version_preference.decode - and+ solver_env = field_o "solver_env" Dune_pkg.Solver_env.decode in + and+ solver_sys_vars = + field_o "solver_sys_vars" Dune_pkg.Solver_env.Variable.Sys.Bindings.decode + and+ repositories_osl = Dune_lang.Ordered_set_lang.field "repositories" in + let repositories = repositories_of_ordered_set repositories_osl in let lock = Option.map lock ~f:Path.as_in_source_tree_exn in fun ~profile_default ~instrument_with_default ~x -> let common = common ~profile_default ~instrument_with_default in @@ -315,17 +330,24 @@ module Context = struct in let name = Option.value ~default name in let base = { common with targets = Target.add common.targets x; name } in - { base; lock; version_preference; solver_env } + { base; lock; version_preference; solver_sys_vars; repositories } ;; - let equal { base; lock; version_preference; solver_env } t = + let equal { base; lock; version_preference; solver_sys_vars; repositories } t = Common.equal base t.base && Option.equal Path.Source.equal lock t.lock && Option.equal Dune_pkg.Version_preference.equal version_preference t.version_preference - && Option.equal Dune_pkg.Solver_env.equal solver_env t.solver_env + && Option.equal + Dune_pkg.Solver_env.Variable.Sys.Bindings.equal + solver_sys_vars + t.solver_sys_vars + && List.equal + Dune_pkg.Pkg_workspace.Repository.Name.equal + repositories + t.repositories ;; end @@ -390,7 +412,8 @@ module Context = struct Default { lock = None ; version_preference = None - ; solver_env = None + ; solver_sys_vars = None + ; repositories = [ Dune_pkg.Pkg_workspace.Repository.Name.of_string "default" ] ; base = { loc = Loc.of_pos __POS__ ; targets = [ Option.value x ~default:Target.Native ] diff --git a/src/dune_rules/workspace.mli b/src/dune_rules/workspace.mli index 244bbd363aa3..8ce4933bbfe8 100644 --- a/src/dune_rules/workspace.mli +++ b/src/dune_rules/workspace.mli @@ -48,7 +48,8 @@ module Context : sig { base : Common.t ; lock : Path.Source.t option ; version_preference : Dune_pkg.Version_preference.t option - ; solver_env : Dune_pkg.Solver_env.t option + ; solver_sys_vars : Dune_pkg.Solver_env.Variable.Sys.Bindings.t option + ; repositories : Dune_pkg.Pkg_workspace.Repository.Name.t list } end diff --git a/test/blackbox-tests/test-cases/pkg/env-conditional-dependencies.t b/test/blackbox-tests/test-cases/pkg/env-conditional-dependencies.t index 1f9b00d7d977..397fd7d20589 100644 --- a/test/blackbox-tests/test-cases/pkg/env-conditional-dependencies.t +++ b/test/blackbox-tests/test-cases/pkg/env-conditional-dependencies.t @@ -33,16 +33,14 @@ Create a workspace config that defines separate build contexts for macos and lin > (default > (name linux) > (lock dune.linux.lock) - > (solver_env - > (sys - > (os linux))))) + > (solver_sys_vars + > (os linux)))) > (context > (default > (name macos) > (lock dune.macos.lock) - > (solver_env - > (sys - > (os macos))))) + > (solver_sys_vars + > (os macos)))) > EOF Now the os-specific dependencies are included on their respective systems. diff --git a/test/blackbox-tests/test-cases/pkg/just-print-solver-env.t b/test/blackbox-tests/test-cases/pkg/just-print-solver-env.t index b649a7158f42..7f83722db2db 100644 --- a/test/blackbox-tests/test-cases/pkg/just-print-solver-env.t +++ b/test/blackbox-tests/test-cases/pkg/just-print-solver-env.t @@ -9,8 +9,6 @@ Print the solver env when no dune-workspace is present - os-family (unset) - Constants - opam-version = 2.2.0~alpha-vendored - - Repositories - default Add some build contexts with different environments $ cat >dune-workspace < (default > (name linux) > (lock dune.linux.lock) - > (solver_env - > (sys - > (os linux))))) + > (solver_sys_vars + > (os linux)))) > (context > (default > (name no-doc) > (lock dune.linux.lock) - > (solver_env - > (sys - > (arch x86_64) - > (os linux) - > (os-family ubuntu) - > (os-distribution ubuntu) - > (os-version 22.04))))) + > (solver_sys_vars + > (arch x86_64) + > (os linux) + > (os-family ubuntu) + > (os-distribution ubuntu) + > (os-version 22.04)))) > EOF $ dune pkg print-solver-env --all-contexts --dont-poll-system-solver-variables @@ -45,8 +41,6 @@ Add some build contexts with different environments - os-family = ubuntu - Constants - opam-version = 2.2.0~alpha-vendored - - Repositories - default Solver environment for context linux: - System Environment Variables - arch (unset) @@ -56,5 +50,3 @@ Add some build contexts with different environments - os-family (unset) - Constants - opam-version = 2.2.0~alpha-vendored - - Repositories - default diff --git a/test/blackbox-tests/test-cases/pkg/multiple-opam-repos.t b/test/blackbox-tests/test-cases/pkg/multiple-opam-repos.t index c1690ec6c93d..d0aad44a9e3e 100644 --- a/test/blackbox-tests/test-cases/pkg/multiple-opam-repos.t +++ b/test/blackbox-tests/test-cases/pkg/multiple-opam-repos.t @@ -38,8 +38,7 @@ We have to define both repositories in the workspace, but will only use `new`. > (context > (default > (name default) - > (solver_env - > (repositories new)))) + > (repositories new))) > EOF $ cat > dune-project < (context > (default > (name default) - > (solver_env - > (repositories old)))) + > (repositories old))) > EOF $ rm -r dune-workspace-cache && mkdir dune-workspace-cache @@ -96,8 +94,7 @@ package: > (context > (default > (name default) - > (solver_env - > (repositories new old)))) + > (repositories new old))) > EOF $ rm -r dune-workspace-cache && mkdir dune-workspace-cache @@ -120,8 +117,7 @@ older version of foo: > (context > (default > (name default) - > (solver_env - > (repositories new old \ new)))) + > (repositories new old \ new))) > EOF $ rm -r dune-workspace-cache && mkdir dune-workspace-cache diff --git a/test/blackbox-tests/test-cases/pkg/opam-repository-download.t b/test/blackbox-tests/test-cases/pkg/opam-repository-download.t index 201e5e2f4f73..128676eb8081 100644 --- a/test/blackbox-tests/test-cases/pkg/opam-repository-download.t +++ b/test/blackbox-tests/test-cases/pkg/opam-repository-download.t @@ -137,8 +137,7 @@ The repository can also be injected via the dune-workspace file > (context > (default > (name default) - > (solver_env - > (repositories foo)))) + > (repositories foo))) > EOF $ mkdir dune-workspace-cache $ XDG_CACHE_HOME=$(pwd)/dune-workspace-cache dune pkg lock diff --git a/test/blackbox-tests/test-cases/pkg/unavailable-packages.t b/test/blackbox-tests/test-cases/pkg/unavailable-packages.t index 0de7894bb51a..fb86670c465c 100644 --- a/test/blackbox-tests/test-cases/pkg/unavailable-packages.t +++ b/test/blackbox-tests/test-cases/pkg/unavailable-packages.t @@ -5,16 +5,14 @@ Set up two build contexts: a default one for linux and another for macos. $ cat >dune-workspace < (lang dune 3.8) > (context (default - > (solver_env - > (sys - > (os linux))))) + > (solver_sys_vars + > (os linux)))) > (context > (default > (name macos) > (lock dune.macos.lock) - > (solver_env - > (sys - > (os macos))))) + > (solver_sys_vars + > (os macos)))) > EOF !! Do not delete this one for the one in helpers.sh as it passes --context !! From 49a1478ff7f89e7a7ee8dc0a5e655baff0cc53a6 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 23 Oct 2023 20:00:36 -0600 Subject: [PATCH 13/20] fix(engine): remove context from action digest (#8972) Signed-off-by: Rudi Grinberg --- bin/print_rules.ml | 4 +- src/dune_engine/build_config.ml | 1 - src/dune_engine/build_config_intf.ml | 2 - src/dune_engine/build_context.ml | 6 +++ src/dune_engine/build_context.mli | 1 + src/dune_engine/build_system.ml | 25 ++++------- src/dune_engine/load_rules.ml | 1 - src/dune_engine/reflection.ml | 2 - src/dune_engine/reflection.mli | 1 - src/dune_engine/rule.ml | 8 ++-- src/dune_engine/rule.mli | 5 +-- src/dune_engine/rules.ml | 5 +-- src/dune_engine/rules.mli | 9 +--- src/dune_rules/artifact_substitution.ml | 45 ++++++++----------- src/dune_rules/artifact_substitution.mli | 2 +- src/dune_rules/configurator_rules.ml | 4 +- src/dune_rules/install_rules.ml | 2 +- src/dune_rules/main.ml | 7 +-- src/dune_rules/pkg_rules.ml | 3 +- src/dune_rules/super_context.ml | 13 +----- .../test-cases/dune-cache/mode-copy.t | 4 +- .../test-cases/dune-cache/mode-hardlink.t | 4 +- .../test-cases/dune-cache/repro-check.t | 6 +-- .../test-cases/dune-cache/trim.t | 4 +- .../test-cases/patch-back-source-tree.t | 2 +- 25 files changed, 63 insertions(+), 103 deletions(-) diff --git a/bin/print_rules.ml b/bin/print_rules.ml index 17c1fed48cd2..1607e5dd50b3 100644 --- a/bin/print_rules.ml +++ b/bin/print_rules.ml @@ -128,9 +128,9 @@ let print_rule_sexp ppf (rule : Dune_engine.Reflection.Rule.t) = ; "directories", paths rule.targets.dirs ] ) ] - ; (match rule.context with + ; (match Path.Build.extract_build_context rule.dir with | None -> [] - | Some c -> [ "context", Dune_engine.Context_name.encode c.name ]) + | Some (c, _) -> [ "context", Dune_sexp.atom_or_quoted_string c ]) ; [ "action", sexp_of_action rule.action ] ]) in diff --git a/src/dune_engine/build_config.ml b/src/dune_engine/build_config.ml index e5d636bb7cd4..1ab1c2b3a66d 100644 --- a/src/dune_engine/build_config.ml +++ b/src/dune_engine/build_config.ml @@ -71,7 +71,6 @@ type t = -> delete_dst_if_it_is_a_directory:bool -> src:Path.Build.t -> dst:Path.Source.t - -> Build_context.t option -> unit Fiber.t ; stats : Dune_stats.t option ; cache_config : Dune_cache.Config.t diff --git a/src/dune_engine/build_config_intf.ml b/src/dune_engine/build_config_intf.ml index f87d46b12829..c7ab4e3bf229 100644 --- a/src/dune_engine/build_config_intf.ml +++ b/src/dune_engine/build_config_intf.ml @@ -129,7 +129,6 @@ module type Build_config = sig -> delete_dst_if_it_is_a_directory:bool -> src:Path.Build.t -> dst:Path.Source.t - -> Build_context.t option -> unit Fiber.t) -> cache_config:Dune_cache.Config.t -> cache_debug_flags:Cache_debug_flags.t @@ -151,7 +150,6 @@ module type Build_config = sig -> delete_dst_if_it_is_a_directory:bool -> src:Path.Build.t -> dst:Path.Source.t - -> Build_context.t option -> unit Fiber.t ; stats : Dune_stats.t option ; cache_config : Dune_cache.Config.t diff --git a/src/dune_engine/build_context.ml b/src/dune_engine/build_context.ml index fca1582521de..a1c0e29242ed 100644 --- a/src/dune_engine/build_context.ml +++ b/src/dune_engine/build_context.ml @@ -9,3 +9,9 @@ let create ~name = let build_dir = Path.Build.of_string (Context_name.to_string name) in { name; build_dir } ;; + +let of_build_path p = + match Dpath.analyse_target p with + | Regular (name, _) | Alias (name, _) | Anonymous_action name -> Some (create ~name) + | Other _ -> None +;; diff --git a/src/dune_engine/build_context.mli b/src/dune_engine/build_context.mli index be63f0d5a4dc..abcedbbac65f 100644 --- a/src/dune_engine/build_context.mli +++ b/src/dune_engine/build_context.mli @@ -11,3 +11,4 @@ type t = private } val create : name:Context_name.t -> t +val of_build_path : Path.Build.t -> t option diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index bc51b67c03fd..83fe57cb47d9 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -235,7 +235,7 @@ end = struct (* The current version of the rule digest scheme. We should increment it when making any changes to the scheme, to avoid collisions. *) - let rule_digest_version = 16 + let rule_digest_version = 17 let compute_rule_digest (rule : Rule.t) @@ -264,7 +264,6 @@ end = struct , sandbox_mode , Dep.Facts.digest deps ~env , file_targets @ dir_targets - , Option.map rule.context ~f:(fun c -> Context_name.to_string c.name) , Action.for_shell action , can_go_in_shared_cache , List.map locks ~f:Path.to_string @@ -314,7 +313,6 @@ end = struct ~action ~deps ~loc - ~(context : Build_context.t option) ~execution_parameters ~sandbox_mode ~dir @@ -369,6 +367,7 @@ end = struct Action.chdirs action |> Path.Build.Set.iter ~f:(fun p -> Path.mkdir_p (Path.build p))) in + let context = Build_context.of_build_path dir in let root = match context with | None -> Path.Build.root @@ -393,7 +392,7 @@ end = struct let* action_exec_result = let input = { Action_exec.root - ; context + ; context (* can be derived from the root *) ; env ; targets = Some targets ; rule_loc = loc @@ -431,7 +430,7 @@ end = struct ;; let execute_rule_impl ~rule_kind rule = - let { Rule.id = _; targets; dir; context; mode; action; info = _; loc } = rule in + let { Rule.id = _; targets; dir; mode; action; info = _; loc } = rule in (* We run [State.start_rule_exn ()] entirely for its side effect, so one might be tempted to use [Memo.of_non_reproducible_fiber] here but that is wrong, because that would force us to rerun [execute_rule_impl] on every @@ -578,7 +577,6 @@ end = struct ~action ~deps ~loc - ~context ~execution_parameters ~sandbox_mode ~dir @@ -617,7 +615,7 @@ end = struct ~rule_mode:mode ~dir ~targets:produced_targets - ~promote_source:(config.promote_source context) + ~promote_source:config.promote_source in let+ () = State.incr_rule_done_exn () in produced_targets) @@ -662,9 +660,8 @@ end = struct Path.Build.relative dir basename in let rule = - let { Rule.Anonymous_action.context; action = _; loc; dir = _; alias = _ } = act in + let { Rule.Anonymous_action.action = _; loc; dir = _; alias = _ } = act in Rule.make - ~context ~info:(if Loc.is_none loc then Internal else From_dune_file loc) ~targets:(Targets.File.create target) ~mode:Standard @@ -729,8 +726,8 @@ end = struct let observing_facts = () in ignore observing_facts; let digest = - let { Rule.Anonymous_action.context - ; action = { action; env; locks; can_go_in_shared_cache; sandbox } + let { Rule.Anonymous_action.action = + { action; env; locks; can_go_in_shared_cache; sandbox } ; loc ; dir ; alias @@ -754,11 +751,7 @@ end = struct |> Env.Map.to_list in Digest.generic - ( Option.map context ~f:(fun c -> - (* Only looking at the context name is fishy, but it is in line - with what we do for build rules. *) - Context_name.to_string c.name) - , env + ( env , Dep.Set.digest deps , Action.for_shell action , List.map locks ~f:Path.to_string diff --git a/src/dune_engine/load_rules.ml b/src/dune_engine/load_rules.ml index 94df88686c9d..8bf5e8c8f954 100644 --- a/src/dune_engine/load_rules.ml +++ b/src/dune_engine/load_rules.ml @@ -332,7 +332,6 @@ end = struct } in Rule.make - ~context:None ~info:(Source_file_copy path) ~targets:(Targets.File.create ctx_path) build) diff --git a/src/dune_engine/reflection.ml b/src/dune_engine/reflection.ml index 9afb0752f42e..14a06fa1b3c6 100644 --- a/src/dune_engine/reflection.ml +++ b/src/dune_engine/reflection.ml @@ -9,7 +9,6 @@ module Rule = struct ; deps : Dep.Set.t ; expanded_deps : Path.Set.t ; targets : Targets.Validated.t - ; context : Build_context.t option ; action : Action.t } end @@ -68,7 +67,6 @@ let evaluate_rule = ; deps ; expanded_deps ; targets = rule.targets - ; context = rule.context ; action = action.action }) in diff --git a/src/dune_engine/reflection.mli b/src/dune_engine/reflection.mli index 057a26213b68..ab193c13e502 100644 --- a/src/dune_engine/reflection.mli +++ b/src/dune_engine/reflection.mli @@ -10,7 +10,6 @@ module Rule : sig variables, universe, glob listings, sandbox requirements *) expanded_deps : Path.Set.t ; targets : Targets.Validated.t - ; context : Build_context.t option ; action : Action.t } end diff --git a/src/dune_engine/rule.ml b/src/dune_engine/rule.ml index 40e3bf926a4b..703e4f88b6d8 100644 --- a/src/dune_engine/rule.ml +++ b/src/dune_engine/rule.ml @@ -53,7 +53,6 @@ module Id = Id.Make () module T = struct type t = { id : Id.t - ; context : Build_context.t option ; targets : Targets.Validated.t ; action : Action.Full.t Action_builder.t ; mode : Mode.t @@ -72,7 +71,7 @@ end include T include Comparable.Make (T) -let make ?(mode = Mode.Standard) ~context ?(info = Info.Internal) ~targets action = +let make ?(mode = Mode.Standard) ?(info = Info.Internal) ~targets action = let action = Action_builder.memoize "Rule.make" action in let report_error ?(extra_pp = []) message = match info with @@ -111,7 +110,7 @@ let make ?(mode = Mode.Standard) ~context ?(info = Info.Internal) ~targets actio (Path.build (Path.Build.relative dir "_unknown_"))) | Source_file_copy p -> Loc.in_file (Path.source p) in - { id = Id.gen (); targets; context; action; mode; info; loc; dir } + { id = Id.gen (); targets; action; mode; info; loc; dir } ;; let set_action t action = @@ -121,8 +120,7 @@ let set_action t action = module Anonymous_action = struct type t = - { context : Build_context.t option - ; action : Action.Full.t + { action : Action.Full.t ; loc : Loc.t ; dir : Path.Build.t ; alias : Alias.Name.t option diff --git a/src/dune_engine/rule.mli b/src/dune_engine/rule.mli index 7a72b76593a6..cbb36fbbe08c 100644 --- a/src/dune_engine/rule.mli +++ b/src/dune_engine/rule.mli @@ -55,7 +55,6 @@ end type t = private { id : Id.t - ; context : Build_context.t option ; targets : Targets.Validated.t ; action : Action.Full.t Action_builder.t ; mode : Mode.t @@ -74,7 +73,6 @@ val to_dyn : t -> Dyn.t [Targets.Validation_result] data type for the list of possible problems. *) val make : ?mode:Mode.t - -> context:Build_context.t option -> ?info:Info.t -> targets:Targets.t -> Action.Full.t Action_builder.t @@ -87,8 +85,7 @@ module Anonymous_action : sig (* jeremiedimino: this type correspond to a subset of [Rule.t]. We should eventually share the code. *) type t = - { context : Build_context.t option - ; action : Action.Full.t + { action : Action.Full.t ; loc : Loc.t ; dir : Path.Build.t (** Directory the action is attached to. This is the directory where diff --git a/src/dune_engine/rules.ml b/src/dune_engine/rules.ml index 12082c34182d..d6cbef709b0f 100644 --- a/src/dune_engine/rules.ml +++ b/src/dune_engine/rules.ml @@ -148,12 +148,11 @@ module Produce = struct } ;; - let add_action t ~context ~loc action = + let add_action t ~loc action = let action = let open Action_builder.O in let+ action = action in - { Rule.Anonymous_action.context = Some context - ; action + { Rule.Anonymous_action.action ; loc ; dir = Alias.dir t ; alias = Some (Alias.name t) diff --git a/src/dune_engine/rules.mli b/src/dune_engine/rules.mli index 6d48e4e36892..907f4ced5cc2 100644 --- a/src/dune_engine/rules.mli +++ b/src/dune_engine/rules.mli @@ -74,14 +74,9 @@ module Produce : sig [alias]. *) val add_deps : t -> ?loc:Stdune.Loc.t -> unit Action_builder.t -> unit Memo.t - (** [add_action alias ~context ~loc action] arrange things so that [action] + (** [add_action alias ~loc action] arrange things so that [action] is executed as part of the build of alias [alias]. *) - val add_action - : t - -> context:Build_context.t - -> loc:Loc.t - -> Action.Full.t Action_builder.t - -> unit Memo.t + val add_action : t -> loc:Loc.t -> Action.Full.t Action_builder.t -> unit Memo.t end end diff --git a/src/dune_rules/artifact_substitution.ml b/src/dune_rules/artifact_substitution.ml index 2c37d71b6c87..7ffcda0dc48d 100644 --- a/src/dune_rules/artifact_substitution.ml +++ b/src/dune_rules/artifact_substitution.ml @@ -115,36 +115,27 @@ module Conf = struct | _ -> None ;; - let of_context (context : Context.t option) = + let of_context (context : Context.t) = let open Memo.O in let get_vcs = Source_tree.nearest_vcs in - match context with - | None -> - { get_vcs - ; get_location = (fun _ _ -> Code_error.raise "no context available" []) - ; get_config_path = (fun _ -> Code_error.raise "no context available" []) - ; sign_hook = Memo.return None - ; hardcoded_ocaml_path = Memo.return @@ Hardcoded [] - } - | Some context -> - let name = Context.name context in - let get_location = Install.Paths.get_local_location name in - let get_config_path = function - | Sourceroot -> Memo.return @@ Some (Path.source Path.Source.root) - | Stdlib -> - let+ ocaml = Context.ocaml context in - Some ocaml.lib_config.stdlib_dir - in - let hardcoded_ocaml_path = - let install_dir = - let install_dir = Install.Context.dir ~context:name in - Path.build (Path.Build.relative install_dir "lib") - in - let+ default_ocamlpath = Context.default_ocamlpath context in - Hardcoded (install_dir :: default_ocamlpath) + let name = Context.name context in + let get_location = Install.Paths.get_local_location name in + let get_config_path = function + | Sourceroot -> Memo.return @@ Some (Path.source Path.Source.root) + | Stdlib -> + let+ ocaml = Context.ocaml context in + Some ocaml.lib_config.stdlib_dir + in + let hardcoded_ocaml_path = + let install_dir = + let install_dir = Install.Context.dir ~context:name in + Path.build (Path.Build.relative install_dir "lib") in - let sign_hook = sign_hook_of_context context in - { get_vcs; get_location; get_config_path; hardcoded_ocaml_path; sign_hook } + let+ default_ocamlpath = Context.default_ocamlpath context in + Hardcoded (install_dir :: default_ocamlpath) + in + let sign_hook = sign_hook_of_context context in + { get_vcs; get_location; get_config_path; hardcoded_ocaml_path; sign_hook } ;; let of_install ~relocatable ~roots ~(context : Context.t) = diff --git a/src/dune_rules/artifact_substitution.mli b/src/dune_rules/artifact_substitution.mli index e7721888653f..a6cd36290a57 100644 --- a/src/dune_rules/artifact_substitution.mli +++ b/src/dune_rules/artifact_substitution.mli @@ -24,7 +24,7 @@ module Conf : sig type t val get_location : t -> Section.t -> Package.Name.t -> Path.t - val of_context : Context.t option -> t + val of_context : Context.t -> t val of_install : relocatable:Path.t option diff --git a/src/dune_rules/configurator_rules.ml b/src/dune_rules/configurator_rules.ml index f4b1acf7e1c7..211b5a3dede9 100644 --- a/src/dune_rules/configurator_rules.ml +++ b/src/dune_rules/configurator_rules.ml @@ -25,7 +25,7 @@ let gen_rules (ctx : Build_context.t) (ocaml : Ocaml_toolchain.t) = |> String.concat ~sep:"" |> Action.write_file fn |> Action.Full.make) - |> Rule.make ~targets:(Targets.File.create fn) ~context:None + |> Rule.make ~targets:(Targets.File.create fn) |> Rules.Produce.rule in let fn = configurator_v2 ctx in @@ -42,7 +42,7 @@ let gen_rules (ctx : Build_context.t) (ocaml : Ocaml_toolchain.t) = |> Csexp.to_string |> Action.write_file fn |> Action.Full.make) - |> Rule.make ~targets:(Targets.File.create fn) ~context:None + |> Rule.make ~targets:(Targets.File.create fn) |> Rules.Produce.rule ;; diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index c5aa1c2b9bcf..91fd9dae51ce 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -927,7 +927,7 @@ let symlink_installed_artifacts_to_build_install in let src = Path.build entry.src in let rule { Action_builder.With_targets.targets; build } = - Rule.make ~info:(From_dune_file loc) ~context:(Some ctx) ~targets build + Rule.make ~info:(From_dune_file loc) ~targets build in match entry.kind with | `Source_tree -> diff --git a/src/dune_rules/main.ml b/src/dune_rules/main.ml index 90935aed80d8..331682303549 100644 --- a/src/dune_rules/main.ml +++ b/src/dune_rules/main.ml @@ -54,12 +54,9 @@ let init () : unit = - let promote_source ~chmod ~delete_dst_if_it_is_a_directory ~src ~dst ctx = + let promote_source ~chmod ~delete_dst_if_it_is_a_directory ~src ~dst = let open Fiber.O in - let* ctx = - Memo.run - (Memo.Option.map ctx ~f:(fun (ctx : Build_context.t) -> Context.DB.get ctx.name)) - in + let* ctx = Path.Build.parent_exn src |> Context.DB.by_dir |> Memo.run in let conf = Artifact_substitution.Conf.of_context ctx in let src = Path.build src in let dst = Path.source dst in diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index 72750d46412d..5de2979e984d 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -1352,8 +1352,7 @@ let add_env env action = let rule ?loc { Action_builder.With_targets.build; targets } = (* TODO this ignores the workspace file *) - Rule.make ~info:(Rule.Info.of_loc_opt loc) ~targets build ~context:None - |> Rules.Produce.rule + Rule.make ~info:(Rule.Info.of_loc_opt loc) ~targets build |> Rules.Produce.rule ;; let source_rules (pkg : Pkg.t) = diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index 942578bc83c6..75ea7b55058e 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -253,12 +253,7 @@ let extend_action t ~dir action = let make_rule t ?mode ?loc ~dir { Action_builder.With_targets.build; targets } = let build = extend_action t build ~dir in - Rule.make - ?mode - ~info:(Rule.Info.of_loc_opt loc) - ~context:(Some (Context.build_context (Env_tree.context t))) - ~targets - build + Rule.make ?mode ~info:(Rule.Info.of_loc_opt loc) ~targets build ;; let add_rule t ?mode ?loc ~dir build = @@ -276,11 +271,7 @@ let add_rules t ?loc ~dir builds = Memo.parallel_iter builds ~f:(add_rule ?loc t let add_alias_action t alias ~dir ~loc action = let build = extend_action t action ~dir in - Rules.Produce.Alias.add_action - ~context:(Context.build_context (Env_tree.context t)) - alias - ~loc - build + Rules.Produce.Alias.add_action alias ~loc build ;; let local_binaries t ~dir = Env_tree.get_node t ~dir >>= Env_node.local_binaries diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t index 55b29acddd2b..168d8d6e05ef 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t @@ -40,9 +40,9 @@ never built [target1] before. $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \ > 2>&1 | grep '_build/default/source\|_build/default/target' Workspace-local cache miss: _build/default/source: never seen this target before - Shared cache miss [9acd3a08d49c004c7c4af47984604b5c] (_build/default/source): not found in cache + Shared cache miss [d008bb41344a7d0d53972220079cbb8c] (_build/default/source): not found in cache Workspace-local cache miss: _build/default/target1: never seen this target before - Shared cache miss [c8ba5d0ce97e5b84d90b24999e54d106] (_build/default/target1): not found in cache + Shared cache miss [b13d2ba64fcb9361d4fe1b3b094f2f82] (_build/default/target1): not found in cache $ dune_cmd stat hardlinks _build/default/source 1 diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t index e18db714d2d1..c26912d6d227 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t @@ -35,9 +35,9 @@ never built [target1] before. $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \ > 2>&1 | grep '_build/default/source\|_build/default/target' Workspace-local cache miss: _build/default/source: never seen this target before - Shared cache miss [4971137801799003aa6e088963677239] (_build/default/source): not found in cache + Shared cache miss [26bdf30e58f853b22578ed89686d983f] (_build/default/source): not found in cache Workspace-local cache miss: _build/default/target1: never seen this target before - Shared cache miss [967c475fcb42c969b0a32a612f7f8918] (_build/default/target1): not found in cache + Shared cache miss [b12a77bbe2d67c323ef28eaaebdcfb34] (_build/default/target1): not found in cache $ dune_cmd stat hardlinks _build/default/source 3 diff --git a/test/blackbox-tests/test-cases/dune-cache/repro-check.t b/test/blackbox-tests/test-cases/dune-cache/repro-check.t index 535f8967aa27..43e352bdf38e 100644 --- a/test/blackbox-tests/test-cases/dune-cache/repro-check.t +++ b/test/blackbox-tests/test-cases/dune-cache/repro-check.t @@ -67,7 +67,7 @@ Set 'cache-check-probability' to 1.0, which should trigger the check > EOF $ rm -rf _build $ dune build --config-file config reproducible non-reproducible - Warning: cache store error [9c0ced5efcd85d0a6c5364bee242c3a2]: ((in_cache + Warning: cache store error [ea838ee96c7527baca974c6516345e68]: ((in_cache ((non-reproducible 1c8fc4744d4cef1bd2b8f5e915b36be9))) (computed ((non-reproducible 6cfaa7a90747882bcf4ffe7252c1cf89)))) after executing (echo 'build non-reproducible';cp dep non-reproducible) @@ -119,7 +119,7 @@ Test that the environment variable and the command line flag work too $ rm -rf _build $ DUNE_CACHE_CHECK_PROBABILITY=1.0 dune build --cache=enabled reproducible non-reproducible - Warning: cache store error [9c0ced5efcd85d0a6c5364bee242c3a2]: ((in_cache + Warning: cache store error [ea838ee96c7527baca974c6516345e68]: ((in_cache ((non-reproducible 1c8fc4744d4cef1bd2b8f5e915b36be9))) (computed ((non-reproducible 6cfaa7a90747882bcf4ffe7252c1cf89)))) after executing (echo 'build non-reproducible';cp dep non-reproducible) @@ -131,7 +131,7 @@ Test that the environment variable and the command line flag work too $ rm -rf _build $ dune build --cache=enabled --cache-check-probability=1.0 reproducible non-reproducible - Warning: cache store error [9c0ced5efcd85d0a6c5364bee242c3a2]: ((in_cache + Warning: cache store error [ea838ee96c7527baca974c6516345e68]: ((in_cache ((non-reproducible 1c8fc4744d4cef1bd2b8f5e915b36be9))) (computed ((non-reproducible 6cfaa7a90747882bcf4ffe7252c1cf89)))) after executing (echo 'build non-reproducible';cp dep non-reproducible) diff --git a/test/blackbox-tests/test-cases/dune-cache/trim.t b/test/blackbox-tests/test-cases/dune-cache/trim.t index 2f84dbdfe39f..1a12431a350d 100644 --- a/test/blackbox-tests/test-cases/dune-cache/trim.t +++ b/test/blackbox-tests/test-cases/dune-cache/trim.t @@ -78,8 +78,8 @@ entries uniformly. $ (cd "$PWD/.xdg-cache/dune/db/meta/v5"; grep -rws . -e 'metadata' | sort ) > out $ cat out - ./25/259be1c0c7a2f2eab4f17969ff8486f5:((8:metadata)(5:files(8:target_a32:5637dd9730e430c7477f52d46de3909c))) - ./f2/f280f0a3c487ec316e741894b164691a:((8:metadata)(5:files(8:target_b32:8a53bfae3829b48866079fa7f2d97781))) + ./c7/c7dd3e91adf65ae3cd721eef06904b93:((8:metadata)(5:files(8:target_b32:8a53bfae3829b48866079fa7f2d97781))) + ./d7/d74e8e6eb3d6cf509b6d3b7cbfeee223:((8:metadata)(5:files(8:target_a32:5637dd9730e430c7477f52d46de3909c))) $ digest="$(awk -F: '/target_b/ { digest=$1 } END { print digest }' < out)" diff --git a/test/blackbox-tests/test-cases/patch-back-source-tree.t b/test/blackbox-tests/test-cases/patch-back-source-tree.t index 86f5d4fd8803..000510adef67 100644 --- a/test/blackbox-tests/test-cases/patch-back-source-tree.t +++ b/test/blackbox-tests/test-cases/patch-back-source-tree.t @@ -201,7 +201,7 @@ produced in the sandbox and copied back: This is the internal stamp file: $ ls _build/.actions/default/blah* - _build/.actions/default/blah-6e90ca359837e9da9d2387e4bdfedc59 + _build/.actions/default/blah-182327d6e04fe09497790fcdbab8ca83 And we check that it isn't copied in the source tree: From b57ab67e6fa666f434baf46bbed932129337bd2b Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 24 Oct 2023 00:20:59 -0600 Subject: [PATCH 14/20] test: (expand_aliases_in_sandbox) should re-run actions (#8991) Signed-off-by: Rudi Grinberg --- .../depend-on/expand-aliases-rerun.t | 27 +++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 test/blackbox-tests/test-cases/depend-on/expand-aliases-rerun.t diff --git a/test/blackbox-tests/test-cases/depend-on/expand-aliases-rerun.t b/test/blackbox-tests/test-cases/depend-on/expand-aliases-rerun.t new file mode 100644 index 000000000000..67363ab1cb94 --- /dev/null +++ b/test/blackbox-tests/test-cases/depend-on/expand-aliases-rerun.t @@ -0,0 +1,27 @@ +Setting (expand_aliases_in_sandbox) should re-run the action + +First, we create an action and make it depend on an alias + + $ cat >dune-project < (lang dune 3.11) + > EOF + $ export DUNE_SANDBOX=symlink + $ cat >dune < (rule + > (alias bar) + > (action (with-stdout-to alias-dep (echo "")))) + > (rule + > (alias foo) + > (deps (alias bar)) + > (action (system "find . | sort"))) + > EOF + $ dune build @foo + . + +Now we set (expand_aliases_in_sandbox), and re-run the action. + + $ cat >dune-project < (lang dune 3.11) + > (expand_aliases_in_sandbox) + > EOF + $ dune build @foo From af9e83812de39259d8254f553fa938c4d95de509 Mon Sep 17 00:00:00 2001 From: Ali Caglayan Date: Tue, 24 Oct 2023 00:00:23 -0700 Subject: [PATCH 15/20] feature: Suggest candidates when alias not found (#7004) Signed-off-by: Ali Caglayan --- bin/alias.ml | 34 +++++++++++++++---- .../test-cases/alias-candidates.t | 18 ++++++++++ .../test-cases/generated-source-dir-overlap.t | 1 + 3 files changed, 47 insertions(+), 6 deletions(-) create mode 100644 test/blackbox-tests/test-cases/alias-candidates.t diff --git a/bin/alias.ml b/bin/alias.ml index 0baa2a08f811..6dc2f89e03a9 100644 --- a/bin/alias.ml +++ b/bin/alias.ml @@ -84,7 +84,7 @@ let dep_on_alias_multi_contexts ~dir ~name ~contexts = let dep_on_alias_rec_multi_contexts ~dir:src_dir ~name ~contexts = let open Action_builder.O in let* dir = Action_builder.of_memo (find_dir_specified_on_command_line ~dir:src_dir) in - let+ alias_statuses = + let* alias_statuses = Action_builder.all (List.map contexts ~f:(fun ctx -> let dir = @@ -94,15 +94,37 @@ let dep_on_alias_rec_multi_contexts ~dir:src_dir ~name ~contexts = in Dune_rules.Alias_rec.dep_on_alias_rec name dir)) in - let is_nonempty = - List.exists alias_statuses ~f:(fun (x : Action_builder.Alias_status.t) -> + match + Alias.is_standard name + || List.exists alias_statuses ~f:(fun (x : Action_builder.Alias_status.t) -> match x with | Defined -> true | Not_defined -> false) - in - if (not is_nonempty) && not (Alias.is_standard name) - then + with + | true -> Action_builder.return () + | false -> + let* load_dir = + Action_builder.all + @@ List.map contexts ~f:(fun ctx -> + let dir = + Source_tree.Dir.path dir + |> Path.Build.append_source (Context_name.build_dir ctx) + |> Path.build + in + Action_builder.of_memo @@ Load_rules.load_dir ~dir) + in + let hints = + let candidates = + Alias.Name.Set.union_map load_dir ~f:(function + | Load_rules.Loaded.Build build -> Alias.Name.Set.of_keys build.aliases + | _ -> Alias.Name.Set.empty) + in + User_message.did_you_mean + (Alias.Name.to_string name) + ~candidates:(Alias.Name.Set.to_list_map ~f:Alias.Name.to_string candidates) + in User_error.raise + ~hints [ Pp.textf "Alias %S specified on the command line is empty." (Alias.Name.to_string name) diff --git a/test/blackbox-tests/test-cases/alias-candidates.t b/test/blackbox-tests/test-cases/alias-candidates.t new file mode 100644 index 000000000000..d3ade0ed8ee1 --- /dev/null +++ b/test/blackbox-tests/test-cases/alias-candidates.t @@ -0,0 +1,18 @@ +Dune should suggest similar aliases when it cannot find one. + + $ cat > dune-project << EOF + > (lang dune 3.7) + > EOF + $ cat > dune << EOF + > (rule + > (alias foo) + > (action + > (echo "Hello, world from \"foo\"!"))) + > EOF + +We have an alias "foo" but let's try to build something misspeled: + $ dune build @fou + Error: Alias "fou" specified on the command line is empty. + It is not defined in . or any of its descendants. + Hint: did you mean fmt or foo? + [1] diff --git a/test/blackbox-tests/test-cases/generated-source-dir-overlap.t b/test/blackbox-tests/test-cases/generated-source-dir-overlap.t index 3c8092119c7a..8f878f343f44 100644 --- a/test/blackbox-tests/test-cases/generated-source-dir-overlap.t +++ b/test/blackbox-tests/test-cases/generated-source-dir-overlap.t @@ -19,6 +19,7 @@ If a generated directory is "overlaid" by a source dir, then things break. $ dune build @foo Error: Alias "foo" specified on the command line is empty. It is not defined in . or any of its descendants. + Hint: did you mean fmt? [1] The command above claims that @foo isn't defined, but it clearly is if we From 6ff407589a424d4ad950dcb24e23d8ea15c4cdc3 Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Tue, 24 Oct 2023 09:09:19 +0200 Subject: [PATCH 16/20] refactor: use Nothing.t (#8985) Some tiny fixes regarding `Nothing`: - do not redefine another empty type - use a pattern in let instead of matching twice Signed-off-by: Etienne Millon --- src/dune_lang/string_with_vars.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/dune_lang/string_with_vars.ml b/src/dune_lang/string_with_vars.ml index c43f53606cae..6f553d851af3 100644 --- a/src/dune_lang/string_with_vars.ml +++ b/src/dune_lang/string_with_vars.ml @@ -305,18 +305,15 @@ module Make_expander (A : Applicative) : Expander with type 'a app := 'a A.t = s Mode.string mode (String.concat (List.concat chunks) ~sep:"")) ;; - type empty = | - let expand : type a. t -> mode:a Mode.t -> dir:Path.t -> f:Value.t list A.t expander -> a A.t = fun t ~mode ~dir ~f -> - let f : (Value.t list, empty) result A.t expander = + let f : (Value.t list, Nothing.t) result A.t expander = fun ~source pform -> f ~source pform |> A.map ~f:Result.ok in - let+ result = expand_result t ~mode ~dir ~f in - match result with - | Ok x -> x + let+ (Ok x) = expand_result t ~mode ~dir ~f in + x ;; let expand_as_much_as_possible t ~dir ~f = From 007a2323adf727679266dc6f29ccb5688ba32c74 Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Tue, 24 Oct 2023 10:25:47 +0200 Subject: [PATCH 17/20] test: directory targets sharing a subdirectory (#8986) Signed-off-by: Etienne Millon --- .../directory-targets/cache-shared-subdir.t | 54 +++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t diff --git a/test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t b/test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t new file mode 100644 index 000000000000..61e558e1e3c7 --- /dev/null +++ b/test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t @@ -0,0 +1,54 @@ +We create 2 directory targets which share a whole subdirectory. + + $ export DUNE_CACHE_ROOT=$PWD/.cache + $ export DUNE_CACHE=enabled + + $ cat > dune-project << EOF + > (lang dune 3.11) + > (using directory-targets 0.1) + > EOF + + $ cat > dune << EOF + > (rule + > (target (dir d1)) + > (action + > (progn + > (run ./gen.sh d1/shared1) + > (no-infer + > (write-file d1/x contents_x))))) + > + > (rule + > (target (dir d2)) + > (action + > (progn + > (run ./gen.sh d2/shared2) + > (no-infer + > (write-file d2/y contents_y))))) + > EOF + + $ cat > gen.sh << 'EOF' + > #!/usr/bin/env sh + > out=$1 + > mkdir -p $out + > echo contents_a > $out/a + > echo contents_b > $out/b + > EOF + $ chmod +x gen.sh + + $ dune build d1/ d2/ + +We expect the targets to be linked in the shared cache. + + $ is_linked() { + > nlinks=$(dune_cmd stat hardlinks $1) + > [ $nlinks -gt 1 ] && echo linked || echo not linked + > } + + $ is_linked _build/default/d1/shared1/a + not linked + $ is_linked _build/default/d1/shared1/b + not linked + $ is_linked _build/default/d2/shared2/a + not linked + $ is_linked _build/default/d2/shared2/b + not linked From f93878b0ff32b019155e7373e446d7c6e68e65ca Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Tue, 24 Oct 2023 11:22:44 +0200 Subject: [PATCH 18/20] test: use a cached file in a directory target (#8984) * test: use a cached file in a directory target We cache a file in a file target and use it in a directory target. Signed-off-by: Etienne Millon * Use a shell script Signed-off-by: Etienne Millon * Extract is_linked to helpers.sh Signed-off-by: Etienne Millon * Fix typo Signed-off-by: Etienne Millon --------- Signed-off-by: Etienne Millon --- .../directory-targets/cache-file-and-dir.t | 51 +++++++++++++++++++ .../directory-targets/cache-shared-subdir.t | 6 +-- .../test-cases/directory-targets/dune | 3 ++ .../test-cases/directory-targets/helpers.sh | 4 ++ 4 files changed, 59 insertions(+), 5 deletions(-) create mode 100644 test/blackbox-tests/test-cases/directory-targets/cache-file-and-dir.t create mode 100644 test/blackbox-tests/test-cases/directory-targets/dune create mode 100644 test/blackbox-tests/test-cases/directory-targets/helpers.sh diff --git a/test/blackbox-tests/test-cases/directory-targets/cache-file-and-dir.t b/test/blackbox-tests/test-cases/directory-targets/cache-file-and-dir.t new file mode 100644 index 000000000000..f7c8ac759a72 --- /dev/null +++ b/test/blackbox-tests/test-cases/directory-targets/cache-file-and-dir.t @@ -0,0 +1,51 @@ +This checks what happens when a file available in the cache is used in a directory target. + + $ export DUNE_CACHE_ROOT=$PWD/.cache + $ export DUNE_CACHE=enabled + $ . ./helpers.sh + + $ cat > dune-project << EOF + > (lang dune 3.11) + > (using directory-targets 0.1) + > EOF + + $ cat > dune << EOF + > (rule + > (with-stdout-to file_out (run ./gen.sh))) + > + > (rule + > (target (dir dir_out)) + > (deps gen.sh) + > (action + > (no-infer + > (progn + > (run mkdir dir_out) + > (with-stdout-to dir_out/a (run ./gen.sh)) + > (write-file dir_out/b contents_b))))) + > EOF + + $ cat > gen.sh << EOF + > #!/usr/bin/env bash + > >&2 echo running command + > echo contents + > EOF + $ chmod +x gen.sh + +We will check whether an entry is linked from the cache. This corresponds to a +file with more than one link. + +We prime the cache with the file: + + $ dune build file_out + running command + $ is_linked _build/default/file_out + linked + +Then use it in the directory target. We expect the command to run (because we +can not know in advance that it is going to generate that file); but to link +the resulting file from the cache. + + $ dune build dir_out/ + running command + $ is_linked _build/default/dir_out/a + not linked diff --git a/test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t b/test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t index 61e558e1e3c7..ca6ef6b606f1 100644 --- a/test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t +++ b/test/blackbox-tests/test-cases/directory-targets/cache-shared-subdir.t @@ -2,6 +2,7 @@ We create 2 directory targets which share a whole subdirectory. $ export DUNE_CACHE_ROOT=$PWD/.cache $ export DUNE_CACHE=enabled + $ . ./helpers.sh $ cat > dune-project << EOF > (lang dune 3.11) @@ -39,11 +40,6 @@ We create 2 directory targets which share a whole subdirectory. We expect the targets to be linked in the shared cache. - $ is_linked() { - > nlinks=$(dune_cmd stat hardlinks $1) - > [ $nlinks -gt 1 ] && echo linked || echo not linked - > } - $ is_linked _build/default/d1/shared1/a not linked $ is_linked _build/default/d1/shared1/b diff --git a/test/blackbox-tests/test-cases/directory-targets/dune b/test/blackbox-tests/test-cases/directory-targets/dune new file mode 100644 index 000000000000..552dd6cf4a96 --- /dev/null +++ b/test/blackbox-tests/test-cases/directory-targets/dune @@ -0,0 +1,3 @@ +(cram + (deps helpers.sh) + (applies_to :whole_subtree)) diff --git a/test/blackbox-tests/test-cases/directory-targets/helpers.sh b/test/blackbox-tests/test-cases/directory-targets/helpers.sh new file mode 100644 index 000000000000..efadf139ced6 --- /dev/null +++ b/test/blackbox-tests/test-cases/directory-targets/helpers.sh @@ -0,0 +1,4 @@ +is_linked() { + nlinks=$(dune_cmd stat hardlinks "$1") + [ "$nlinks" -gt 1 ] && echo linked || echo not linked +} From 948b9be66711b05e921588eb7a9f16a7b8620f97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Wed, 25 Oct 2023 00:04:28 +0200 Subject: [PATCH 19/20] melange: remove ppx flag from merlin (#8992) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * melange: don't include melc -as-ppx in merlin * remove melc_flags altogether * clean up test file Signed-off-by: Javier Chávarri --- src/dune_rules/merlin/merlin.ml | 53 ++++--------------- .../test-cases/melange/merlin.t | 25 ++------- test/expect-tests/persistent_tests.ml | 2 +- 3 files changed, 14 insertions(+), 66 deletions(-) diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml index e0ec50ced242..88ecc8db9b85 100644 --- a/src/dune_rules/merlin/merlin.ml +++ b/src/dune_rules/merlin/merlin.ml @@ -51,10 +51,9 @@ module Processed = struct ; src_dirs : Path.Set.t ; flags : string list ; extensions : string option Ml_kind.Dict.t list - ; melc_flags : string list } - let dyn_of_config { stdlib_dir; obj_dirs; src_dirs; flags; extensions; melc_flags } = + let dyn_of_config { stdlib_dir; obj_dirs; src_dirs; flags; extensions } = let open Dyn in record [ "stdlib_dir", option Path.to_dyn stdlib_dir @@ -62,7 +61,6 @@ module Processed = struct ; "src_dirs", Path.Set.to_dyn src_dirs ; "flags", list string flags ; "extensions", list (Ml_kind.Dict.to_dyn (Dyn.option string)) extensions - ; "melc_flags", list string melc_flags ] ;; @@ -106,7 +104,6 @@ module Processed = struct ; src_dirs = Path.Set.empty ; flags = [ "-x" ] ; extensions = [ { Ml_kind.Dict.intf = None; impl = Some "ext" } ] - ; melc_flags = [ "-y" ] } ; per_module_config = Path.Build.Map.empty ; pp_config = @@ -146,8 +143,7 @@ module Processed = struct | None, None -> None ;; - let to_sexp ~opens ~pp { stdlib_dir; obj_dirs; src_dirs; flags; extensions; melc_flags } - = + let to_sexp ~opens ~pp { stdlib_dir; obj_dirs; src_dirs; flags; extensions } = let make_directive tag value = Sexp.List [ Atom tag; value ] in let make_directive_of_path tag path = make_directive tag (Sexp.Atom (serialize_path path)) @@ -167,13 +163,6 @@ module Processed = struct | flags -> [ make_directive "FLG" (Sexp.List (List.map ~f:(fun s -> Sexp.Atom s) flags)) ] in - let flags = - match melc_flags with - | [] -> flags - | melc_flags -> - make_directive "FLG" (Sexp.List (List.map ~f:(fun s -> Sexp.Atom s) melc_flags)) - :: flags - in let flags = match pp with | None -> flags @@ -286,7 +275,7 @@ module Processed = struct | Error msg -> Printf.eprintf "%s\n" msg | Ok [] -> Printf.eprintf "No merlin configuration found.\n" | Ok (init :: tl) -> - let pp_configs, obj_dirs, src_dirs, flags, extensions, melc_flags = + let pp_configs, obj_dirs, src_dirs, flags, extensions = (* We merge what is easy to merge and ignore the rest *) List.fold_left tl @@ -295,30 +284,20 @@ module Processed = struct , init.config.obj_dirs , init.config.src_dirs , [ init.config.flags ] - , init.config.extensions - , init.config.melc_flags ) + , init.config.extensions ) ~f: (fun - (acc_pp, acc_obj, acc_src, acc_flags, acc_ext, acc_melc_flags) + (acc_pp, acc_obj, acc_src, acc_flags, acc_ext) { per_module_config = _ ; pp_config - ; config = - { stdlib_dir = _; obj_dirs; src_dirs; flags; extensions; melc_flags } + ; config = { stdlib_dir = _; obj_dirs; src_dirs; flags; extensions } } -> ( pp_config :: acc_pp , Path.Set.union acc_obj obj_dirs , Path.Set.union acc_src src_dirs , flags :: acc_flags - , extensions @ acc_ext - , match acc_melc_flags with - | [] -> melc_flags - | acc_melc_flags -> acc_melc_flags )) - in - let flags = - match melc_flags with - | [] -> flags - | melc -> melc :: flags + , extensions @ acc_ext )) in Printf.printf "%s\n" @@ -564,8 +543,8 @@ module Unprocessed = struct Lib.Set.union requires (Lib.Set.of_list libs) | None -> Memo.return requires) in - let* flags = flags - and* src_dirs, obj_dirs = + let+ flags = flags + and+ src_dirs, obj_dirs = Action_builder.of_memo (let open Memo.O in Memo.parallel_map (Lib.Set.to_list requires) ~f:(fun lib -> @@ -584,19 +563,7 @@ module Unprocessed = struct let src_dirs = Path.Set.union src_dirs (Path.Set.of_list_map ~f:Path.source more_src_dirs) in - let+ melc_flags = - match t.config.mode with - | Ocaml _ -> Action_builder.return [] - | Melange -> - let+ melc_compiler = - Action_builder.of_memo (Melange_binary.melc sctx ~loc:None ~dir) - in - (match melc_compiler with - | Error _ -> [] - | Ok path -> - [ Processed.Pp_kind.to_flag Ppx; Processed.serialize_path path ^ " -as-ppx" ]) - in - { Processed.stdlib_dir; src_dirs; obj_dirs; flags; extensions; melc_flags } + { Processed.stdlib_dir; src_dirs; obj_dirs; flags; extensions } and+ pp_config = pp_config t sctx ~expander in let per_module_config = (* And copy for each module the resulting pp flags *) diff --git a/test/blackbox-tests/test-cases/melange/merlin.t b/test/blackbox-tests/test-cases/melange/merlin.t index f2b2034d2d19..f1ae8073b2a8 100644 --- a/test/blackbox-tests/test-cases/melange/merlin.t +++ b/test/blackbox-tests/test-cases/melange/merlin.t @@ -43,17 +43,11 @@ Paths to Melange stdlib appear in B and S entries without melange.emit stanza S /MELC_STDLIB S $TESTCASE_ROOT -All 3 modules (Foo, Foo__ and Bar) contain a ppx directive - - $ dune ocaml merlin dump-config $PWD | grep -i "ppx" - (FLG (-ppx "/MELC_COMPILER -as-ppx")) - (FLG (-ppx "/MELC_COMPILER -as-ppx")) - (FLG (-ppx "/MELC_COMPILER -as-ppx")) - $ target=output $ cat >dune < (melange.emit > (target "$target") + > (compile_flags :standard -bs-D DEBUG=true ) > (modules main)) > EOF @@ -62,11 +56,6 @@ All 3 modules (Foo, Foo__ and Bar) contain a ppx directive $ dune ocaml merlin dump-config $PWD | grep -i "$target" $TESTCASE_ROOT/_build/default/.output.mobjs/melange) -The melange.emit entry contains a ppx directive - - $ dune ocaml merlin dump-config $PWD | grep -i "ppx" - (FLG (-ppx "/MELC_COMPILER -as-ppx")) - Dump-dot-merlin includes the melange flags $ dune ocaml dump-dot-merlin $PWD @@ -80,13 +69,8 @@ Dump-dot-merlin includes the melange flags S /MELC_STDLIB S /MELC_STDLIB S $TESTCASE_ROOT - # FLG -ppx '/MELC_COMPILER -as-ppx' - # FLG -w @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 -strict-sequence -strict-formats -short-paths -keep-locs -g + # FLG -w @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 -strict-sequence -strict-formats -short-paths -keep-locs -g -bs-D DEBUG=true - - - - Check for flag directives ordering when another preprocessor is defined $ cat >fooppx.ml < Date: Wed, 25 Oct 2023 17:35:19 +0200 Subject: [PATCH 20/20] chore: update ppx_expect to 0.16 (#8995) Signed-off-by: Etienne Millon --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 962f598c7d6d..2823168399ef 100644 --- a/Makefile +++ b/Makefile @@ -20,7 +20,7 @@ menhir \ ocamlfind \ ocamlformat.$$(awk -F = '$$1 == "version" {print $$2}' .ocamlformat) \ "odoc>=2.0.1" \ -"ppx_expect.v0.15.0" \ +"ppx_expect>=v0.16.0" \ ppx_inline_test \ ppxlib \ ctypes \