From 047a7a7fd71315944e42f6d199409b4138a4db79 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 27 Oct 2021 16:25:05 +0100 Subject: [PATCH 01/32] Fix some tests in Mac OS CI (#5057) Apparently #5025 introduced a couple of tests problematic on Mac OS. Fixing. Signed-off-by: Andrey Mokhov --- bin/print_rules.ml | 2 +- test/blackbox-tests/test-cases/directory-targets.t/run.t | 4 +++- test/blackbox-tests/test-cases/pipe-actions.t/run.t | 4 +--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/bin/print_rules.ml b/bin/print_rules.ml index 6e38377b5c4a..614ffb3bd559 100644 --- a/bin/print_rules.ml +++ b/bin/print_rules.ml @@ -40,7 +40,7 @@ let print_rule_makefile ppf (rule : Dune_engine.Reflection.Rule.t) = Path.Build.Set.union files dirs) in Format.fprintf ppf - "@[@{%a:%t@}@]@,@<0>\t@{%a@}@,@," + "@[@{%a:%t@}@]@,@<0>\t@{%a@}\n" (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p -> Format.pp_print_string ppf (Path.to_string p))) (List.map ~f:Path.build (Path.Build.Set.to_list targets)) diff --git a/test/blackbox-tests/test-cases/directory-targets.t/run.t b/test/blackbox-tests/test-cases/directory-targets.t/run.t index c83f1bf52952..d93f6bc95a83 100644 --- a/test/blackbox-tests/test-cases/directory-targets.t/run.t +++ b/test/blackbox-tests/test-cases/directory-targets.t/run.t @@ -121,7 +121,7 @@ Print rules: currently works only with Makefiles. # CR-someday amokhov: Add support for printing Dune rules. - $ dune rules -m output | tr '\t' ' ' | head -n -1 + $ dune rules -m output | tr '\t' ' ' _build/default/output: _build/default/src_x mkdir -p _build/default; \ mkdir -p _build/default; \ @@ -322,6 +322,7 @@ mtime changes when the rule reruns. We can delete this when switching to (1). There is no early cutoff on directory targets at the moment. Ideally, we should skip the second action since the produced directory has the same contents. + $ dune_cmd wait-for-fs-clock-to-advance $ echo new-cc > src_c $ dune build contents bash output @@ -338,6 +339,7 @@ There is no shared cache support for directory targets at the moment. Note that we rerun both actions: the first one because there is no shared cache support and the second one because of the lack of early cutoff. + $ dune_cmd wait-for-fs-clock-to-advance $ rm _build/default/output/a $ dune build contents bash output diff --git a/test/blackbox-tests/test-cases/pipe-actions.t/run.t b/test/blackbox-tests/test-cases/pipe-actions.t/run.t index 02a6010961a9..01c654de110e 100644 --- a/test/blackbox-tests/test-cases/pipe-actions.t/run.t +++ b/test/blackbox-tests/test-cases/pipe-actions.t/run.t @@ -44,7 +44,6 @@ The makefile version of pipe actions uses actual pipes: $ cat >dune < (executables > (public_names a b c)) - > > (rule > (alias pipe) > (action @@ -60,13 +59,12 @@ The makefile version of pipe actions uses actual pipes: cd _build/default; \ ../install/default/bin/a 2>&1 | \ ../install/default/bin/b | ../install/default/bin/c &> target - + $ cat >dune < (executable > (public_name apl) (name append_to_line) (modules append_to_line)) > (executable > (public_name echo-outputs) (name echo_outputs) (modules echo_outputs)) - > > (rule > (action > (with-stderr-to target-stdout.stderr From 5a4469403a795dc4ef592b7b21c99d85072bfdad Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 27 Oct 2021 16:27:27 +0100 Subject: [PATCH 02/32] Add Memo.Lazy.Expert.create (#5058) This is needed in #5053. Signed-off-by: Andrey Mokhov --- src/memo/memo.ml | 18 ++++++++++----- src/memo/memo.mli | 57 ++++++++++++++++++++++++++++------------------- 2 files changed, 47 insertions(+), 28 deletions(-) diff --git a/src/memo/memo.ml b/src/memo/memo.ml index e7614d33d4c9..4e6aa3ad2bbf 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -1555,10 +1555,6 @@ let lazy_cell ?cutoff ?name ?human_readable_description f = in make_dep_node ~spec ~input:() -let lazy_ ?cutoff ?name ?human_readable_description f = - let cell = lazy_cell ?cutoff ?name ?human_readable_description f in - fun () -> Cell.read cell - let push_stack_frame ~human_readable_description f = Cell.read (lazy_cell ~human_readable_description f) @@ -1567,13 +1563,25 @@ module Lazy = struct let of_val a () = Fiber.return a - let create = lazy_ + module Expert = struct + let create ?cutoff ?name ?human_readable_description f = + let cell = lazy_cell ?cutoff ?name ?human_readable_description f in + (cell, fun () -> Cell.read cell) + end + + let create ?cutoff ?name ?human_readable_description f = + let (_ : (unit, 'a) Cell.t), t = + Expert.create ?cutoff ?name ?human_readable_description f + in + t let force f = f () let map t ~f = create (fun () -> Fiber.map ~f (t ())) end +let lazy_ = Lazy.create + module Poly (Function : sig type 'a input diff --git a/src/memo/memo.mli b/src/memo/memo.mli index fc2223222deb..9b403b09920f 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -328,6 +328,29 @@ end (** Introduces a dependency on the current build run. *) val current_run : unit -> Run.t Build.t +module Cell : sig + type ('i, 'o) t + + val input : ('i, _) t -> 'i + + val read : (_, 'o) t -> 'o Build.t + + (** Mark this cell as invalid, forcing recomputation of this value. The + consumers may be recomputed or not, depending on early cutoff. *) + val invalidate : reason:Invalidation.Reason.t -> _ t -> Invalidation.t +end + +(** Create a "memoization cell" that focuses on a single input/output pair of a + memoized function. *) +val cell : ('i, 'o) t -> 'i -> ('i, 'o) Cell.t + +val lazy_cell : + ?cutoff:('a -> 'a -> bool) + -> ?name:string + -> ?human_readable_description:(unit -> User_message.Style.t Pp.t) + -> (unit -> 'a Build.t) + -> (unit, 'a) Cell.t + module Lazy : sig type 'a t @@ -343,6 +366,17 @@ module Lazy : sig val force : 'a t -> 'a Build.t val map : 'a t -> f:('a -> 'b) -> 'b t + + module Expert : sig + (** Like [Lazy.create] but returns the underlying Memo [Cell], which can be + useful for testing and debugging. *) + val create : + ?cutoff:('a -> 'a -> bool) + -> ?name:string + -> ?human_readable_description:(unit -> User_message.Style.t Pp.t) + -> (unit -> 'a Build.t) + -> (unit, 'a) Cell.t * 'a t + end end val lazy_ : @@ -393,29 +427,6 @@ module With_implicit_output : sig val exec : ('i, 'o) t -> 'i -> 'o Build.t end -module Cell : sig - type ('i, 'o) t - - val input : ('i, _) t -> 'i - - val read : (_, 'o) t -> 'o Build.t - - (** Mark this cell as invalid, forcing recomputation of this value. The - consumers may be recomputed or not, depending on early cutoff. *) - val invalidate : reason:Invalidation.Reason.t -> _ t -> Invalidation.t -end - -(** Create a "memoization cell" that focuses on a single input/output pair of a - memoized function. *) -val cell : ('i, 'o) t -> 'i -> ('i, 'o) Cell.t - -val lazy_cell : - ?cutoff:('a -> 'a -> bool) - -> ?name:string - -> ?human_readable_description:(unit -> User_message.Style.t Pp.t) - -> (unit -> 'a Build.t) - -> (unit, 'a) Cell.t - (** Memoization of polymorphic functions ['a input -> 'a output Build.t]. The provided [id] function must be injective, i.e. there must be a one-to-one correspondence between [input]s and their [id]s. *) From aaa83e714e1ab1e697424e06986192a979a191dd Mon Sep 17 00:00:00 2001 From: Callum Moseley Date: Thu, 28 Oct 2021 15:38:16 +0100 Subject: [PATCH 03/32] Fix typos (#5060) * Fix some typos Signed-off-by: Callum Moseley --- otherlibs/stdune-unstable/path.mli | 2 +- src/dune_engine/build_system.ml | 5 ++--- src/dune_engine/dep.ml | 2 +- src/dune_engine/print_diff.ml | 4 ++-- src/dune_engine/string_with_vars.mli | 10 +++++----- src/dune_rules/odoc.ml | 2 +- .../test-cases/actions/action-stdxxx-on-success.t | 2 +- .../variables/named-dep-in-diff-question-mark.t | 2 +- test/expect-tests/fiber/fiber_tests.ml | 2 +- 9 files changed, 15 insertions(+), 16 deletions(-) diff --git a/otherlibs/stdune-unstable/path.mli b/otherlibs/stdune-unstable/path.mli index 928ce3c40f8a..1de6f7e50392 100644 --- a/otherlibs/stdune-unstable/path.mli +++ b/otherlibs/stdune-unstable/path.mli @@ -137,7 +137,7 @@ module Build : sig val append_local : t -> Local.t -> t - (** [append x y] is [append_local x (local y] *) + (** [append x y] is [append_local x (local y)] *) val append : t -> t -> t module L : sig diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 32f8c9505e12..7313c8eb014a 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -1797,9 +1797,8 @@ end = struct {v (rule (alias runtest) (targets x) (action ...)) v} - These will be treated as [Normal_rule], and the bellow match - means that [--force] will have no effect on them. Is that what we - want? + These will be treated as [Normal_rule], and the below match means + that [--force] will have no effect on them. Is that what we want? The doc says: diff --git a/src/dune_engine/dep.ml b/src/dune_engine/dep.ml index 8a582f9e0ad8..05813988f3a3 100644 --- a/src/dune_engine/dep.ml +++ b/src/dune_engine/dep.ml @@ -325,7 +325,7 @@ module Facts = struct | Universe -> acc | Sandbox_config config -> assert (Sandbox_config.mem config sandbox_mode); - (* recorded globally for the whole dep set, see bellow *) + (* recorded globally for the whole dep set, see below *) acc | File _ | File_selector _ diff --git a/src/dune_engine/print_diff.ml b/src/dune_engine/print_diff.ml index 96f03e5ad948..a27b823a60dd 100644 --- a/src/dune_engine/print_diff.ml +++ b/src/dune_engine/print_diff.ml @@ -47,7 +47,7 @@ let print ?(skip_trailing_cr = Sys.win32) annot path1 path2 = let dir = (* We can't run [git] from [dir] as [dir] might be inside a sandbox and sandboxes have fake [.git] files to stop [git] from escaping - the sandbox. If we did, the bellow git command would fail saying it + the sandbox. If we did, the below git command would fail saying it can run this fake [.git] file. *) Path.root in @@ -115,7 +115,7 @@ let print ?(skip_trailing_cr = Sys.win32) annot path1 path2 = the output, so the [process] module won't recognise that the output has a location. - For this reason, we manually pass the bellow annotation. *) + For this reason, we manually pass the below annotation. *) Internal_job ( Some loc , [ annot; User_error.Annot.Has_embedded_location.make () ] )) diff --git a/src/dune_engine/string_with_vars.mli b/src/dune_engine/string_with_vars.mli index dfc9d6767a8c..05e0fec864b8 100644 --- a/src/dune_engine/string_with_vars.mli +++ b/src/dune_engine/string_with_vars.mli @@ -57,11 +57,11 @@ val text_only : t -> string option module Mode : sig (** How many values expansion of a template must produce. - The caller always knows which of the contexts bellow it requires, - therefore it can specify this to the expansion functions. This allows us - to return a precise result type from the expansion, and do some validation - to make sure we aren't expanding into multiple values in cases where it's - not allowed. *) + The caller always knows which of the contexts below it requires, therefore + it can specify this to the expansion functions. This allows us to return a + precise result type from the expansion, and do some validation to make + sure we aren't expanding into multiple values in cases where it's not + allowed. *) type _ t = | Single : Value.t t (** Expansion must produce a single value *) | Many : Value.t list t (** Expansion may produce any number of values *) diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index 5e254d5effba..4a8289f4a3d0 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -259,7 +259,7 @@ let setup_html sctx (odoc_file : odoc) ~pkg ~requires = match odoc_file.source with | Mld -> (odoc_file.html_file, []) | Module -> - (* Dummy target so that the bellow rule as at least one target. We do this + (* Dummy target so that the below rule as at least one target. We do this because we don't know the targets of odoc in this case. The proper way to support this would be to have directory targets. *) let dummy = Action_builder.create_file (odoc_file.html_dir ++ ".dummy") in diff --git a/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t b/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t index 80271bdb323a..2dc5e2eac25b 100644 --- a/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t +++ b/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t @@ -127,7 +127,7 @@ re-execute actions whose outcome is not affected by the change: sh alias default b.stderr -You can observe in the bellow call that both actions are being +You can observe in the below call that both actions are being re-executed: $ dune build diff --git a/test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t b/test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t index 7e0125d0108e..ed56ec3c8db3 100644 --- a/test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t +++ b/test/blackbox-tests/test-cases/variables/named-dep-in-diff-question-mark.t @@ -3,7 +3,7 @@ Regression test for using %{test} in (diff ...) The action expander treats the second argument of diff? as "consuming a target". Since targets needs to be known at rule creation time rather than at rule evaluation time and dependencies are usually -evaluated at the latter stage, the bellow pattern could break if we +evaluated at the latter stage, the below pattern could break if we are not careful. We want to support it because it is a common pattern. $ echo '(lang dune 2.8)' > dune-project diff --git a/test/expect-tests/fiber/fiber_tests.ml b/test/expect-tests/fiber/fiber_tests.ml index e550d66c1b9d..3fa29530979c 100644 --- a/test/expect-tests/fiber/fiber_tests.ml +++ b/test/expect-tests/fiber/fiber_tests.ml @@ -524,7 +524,7 @@ let%expect_test "writing multiple values" = Fiber.fork_and_join_unit (fun () -> produce 3) consume); (* Writing to a mvar only blocks if the mvar is full. Similarly, reading from a mvar only blocks if the mvar is empty. This is why [write] and [read] - operations in the output bellow are grouped two by two. *) + operations in the output below are grouped two by two. *) [%expect {| writing 3 From 293742d6b1456c1d54a63705a774f3372c0b69a2 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 28 Oct 2021 17:21:31 +0100 Subject: [PATCH 04/32] Refactor load_dir_step2_exn (#5062) Whenever I come across [load_dir_step2_exn] I'm puzzled by the invariant that the caller is supposed to satisfy. This PR simplifies things a bit by getting rid of some unsafety. Also, the return type is now more precise. There is no change in behaviour. Signed-off-by: Andrey Mokhov --- src/dune_engine/build_system.ml | 76 ++++++++++++++++----------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 7313c8eb014a..50786373869d 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -149,12 +149,6 @@ module Loaded = struct } end -module Dir_triage = struct - type t = - | Known of Loaded.t - | Need_step2 -end - (* Stores information needed to determine if rule need to be reexecuted. *) module Trace_db : sig module Entry : sig @@ -294,6 +288,16 @@ module Context_or_install = struct | Context s -> Context_name.to_dyn s end +module Dir_triage = struct + type t = + | Known of Loaded.t + | Need_step2 of + { dir : Path.Build.t + ; context_or_install : Context_or_install.t + ; sub_dir : Path.Source.t + } +end + module Error = struct module Id = Id.Make () @@ -471,9 +475,18 @@ let get_dir_triage t ~dir = | Build (Invalid _) -> Memo.Build.return @@ Dir_triage.Known (Loaded.no_rules ~allowed_subdirs:Dir_set.empty) - | Build (Install (With_context _)) - | Build (Regular (With_context _)) -> - Memo.Build.return @@ Dir_triage.Need_step2 + | Build (Install (With_context (context_name, sub_dir))) -> + (* In this branch, [dir] is in the build directory. *) + let dir = Path.as_in_build_dir_exn dir in + let context_or_install = Context_or_install.Install context_name in + Memo.Build.return + (Dir_triage.Need_step2 { dir; context_or_install; sub_dir }) + | Build (Regular (With_context (context_name, sub_dir))) -> + (* In this branch, [dir] is in the build directory. *) + let dir = Path.as_in_build_dir_exn dir in + let context_or_install = Context_or_install.Context context_name in + Memo.Build.return + (Dir_triage.Need_step2 { dir; context_or_install; sub_dir }) let describe_rule (rule : Rule.t) = match rule.info with @@ -1025,30 +1038,16 @@ end = struct in source_files_to_ignore - (* Returns only [Loaded.Build] variant. *) - let load_dir_step2_exn t ~dir = - let context_name, sub_dir = - match Dpath.analyse_path dir with - | Build (Install (ctx, path)) -> (Context_or_install.Install ctx, path) - | Build (Regular (ctx, path)) -> (Context_or_install.Context ctx, path) - | Build (Alias _) - | Build (Anonymous_action _) - | Build (Other _) - | Source _ - | External _ -> - Code_error.raise "[load_dir_step2_exn] was called on a strange path" - [ ("path", Path.to_dyn dir) ] - in - (* the above check makes this safe *) - let dir = Path.as_in_build_dir_exn dir in + let load_dir_step2_exn t ~dir ~context_or_install ~sub_dir = let sub_dir_components = Path.Source.explode sub_dir in (* Load all the rules *) let (module RG : Rule_generator) = t.rule_generator in let* extra_subdirs_to_keep, rules_produced = - RG.gen_rules context_name ~dir sub_dir_components >>| function + RG.gen_rules context_or_install ~dir sub_dir_components >>| function | None -> Code_error.raise "[gen_rules] did not specify rules for the context" - [ ("context_name", Context_or_install.to_dyn context_name) ] + [ ("context_or_install", Context_or_install.to_dyn context_or_install) + ] | Some x -> x and* global_rules = Memo.Lazy.force RG.global_rules in let rules = @@ -1060,13 +1059,13 @@ end = struct let collected = Rules.Dir_rules.consume rules in let rules = collected.rules in let* aliases = - match context_name with + match context_or_install with | Context _ -> compute_alias_expansions t ~collected ~dir | Install _ -> (* There are no aliases in the [_build/install] directory *) Memo.Build.return Alias.Name.Map.empty and* source_tree_dir = - match context_name with + match context_or_install with | Install _ -> Memo.Build.return None | Context _ -> Source_tree.find_dir sub_dir in @@ -1116,7 +1115,7 @@ end = struct in (* Take into account the source files *) let to_copy, source_dirs = - match context_name with + match context_or_install with | Install _ -> (None, String.Set.empty) | Context context_name -> let files, subdirs = @@ -1156,7 +1155,7 @@ end = struct in let rules_here = compile_rules ~dir ~source_dirs rules in let* allowed_by_parent = - match (context_name, sub_dir_components) with + match (context_or_install, sub_dir_components) with | Context _, [ ".dune" ] -> (* GROSS HACK: this is to avoid a cycle as the rules for all directories force the generation of ".dune/configurator". We need a better way to @@ -1211,17 +1210,18 @@ end = struct (Path.Build.local dir)) ~subdirs_to_keep; Memo.Build.return - (Loaded.Build - { allowed_subdirs = descendants_to_keep - ; rules_produced - ; rules_here - ; aliases - }) + { Loaded.allowed_subdirs = descendants_to_keep + ; rules_produced + ; rules_here + ; aliases + } let load_dir_impl t ~dir : Loaded.t Memo.Build.t = get_dir_triage t ~dir >>= function | Known l -> Memo.Build.return l - | Need_step2 -> load_dir_step2_exn t ~dir + | Need_step2 { dir; context_or_install; sub_dir } -> + let+ build = load_dir_step2_exn t ~dir ~context_or_install ~sub_dir in + Loaded.Build build let load_dir = let load_dir_impl dir = load_dir_impl (t ()) ~dir in From cac3d884378c812ed9348d120bc3113615a519b2 Mon Sep 17 00:00:00 2001 From: Callum Moseley Date: Fri, 29 Oct 2021 13:23:43 +0100 Subject: [PATCH 05/32] Draft: Add option to dump memo graph after build (#5053) * Add option to dump memo graph after build completes Signed-off-by: Callum Moseley --- bin/arg.ml | 3 + bin/arg.mli | 2 + bin/build_cmd.ml | 37 ++- bin/common.ml | 38 +++ bin/common.mli | 6 + bin/dune | 1 + bin/import.ml | 1 + boot/libs.ml | 1 + src/dune_graph/dune | 3 + src/dune_graph/dune_graph.ml | 1 + src/dune_graph/graph.ml | 314 ++++++++++++++++++ src/dune_graph/graph.mli | 67 ++++ src/memo/dune | 2 +- src/memo/memo.ml | 42 +++ src/memo/memo.mli | 7 + .../test-cases/dump-graph.t/run.t | 28 ++ .../memo/graph_dump/dump_graph_tests.ml | 183 ++++++++++ test/expect-tests/memo/graph_dump/dune | 16 + 18 files changed, 745 insertions(+), 7 deletions(-) create mode 100644 src/dune_graph/dune create mode 100644 src/dune_graph/dune_graph.ml create mode 100644 src/dune_graph/graph.ml create mode 100644 src/dune_graph/graph.mli create mode 100644 test/blackbox-tests/test-cases/dump-graph.t/run.t create mode 100644 test/expect-tests/memo/graph_dump/dump_graph_tests.ml create mode 100644 test/expect-tests/memo/graph_dump/dune diff --git a/bin/arg.ml b/bin/arg.ml index 7edd8db06bb7..9d36c42b372b 100644 --- a/bin/arg.ml +++ b/bin/arg.ml @@ -123,6 +123,9 @@ let bytes = in conv (decode, pp_print_int64) +let graph_format : Dune_graph.Graph.File_format.t conv = + conv Dune_graph.Graph.File_format.conv + let context_name : Context_name.t conv = conv Context_name.conv let lib_name = conv Dune_engine.Lib_name.conv diff --git a/bin/arg.mli b/bin/arg.mli index 9cf4d574da1e..a79d16c75062 100644 --- a/bin/arg.mli +++ b/bin/arg.mli @@ -32,6 +32,8 @@ val context_name : Context_name.t conv val dep : Dep.t conv +val graph_format : Dune_graph.Graph.File_format.t conv + val path : Path.t conv val package_name : Package.Name.t conv diff --git a/bin/build_cmd.ml b/bin/build_cmd.ml index 89ab2c39cc9d..a0aed7f6d697 100644 --- a/bin/build_cmd.ml +++ b/bin/build_cmd.ml @@ -24,12 +24,9 @@ let with_metrics ~common f = Fiber.return ()) let run_build_system ~common ~request = - let run ~(request : unit Action_builder.t) = + let run ~(toplevel : unit Memo.Lazy.t) = with_metrics ~common (fun () -> - Build_system.run (fun () -> - let open Memo.Build.O in - let+ (), _facts = Action_builder.run request Eager in - ())) + Build_system.run (fun () -> Memo.Lazy.force toplevel)) in let open Fiber.O in Fiber.finalize @@ -47,7 +44,35 @@ let run_build_system ~common ~request = Action_builder.bind (Action_builder.memo_build setup) ~f:(fun setup -> request setup) in - run ~request) + (* CR-someday cmoseley: Can we avoid creating a new lazy memo node every + time the build system is rerun? *) + (* This top-level node is used for traversing the whole Memo graph. *) + let toplevel_cell, toplevel = + Memo.Lazy.Expert.create ~name:"toplevel" (fun () -> + let open Memo.Build.O in + let+ (), (_ : Dep.Fact.t Dep.Map.t) = + Action_builder.run request Eager + in + ()) + in + let* res = run ~toplevel in + let+ () = + match Common.dump_memo_graph_file common with + | None -> Fiber.return () + | Some file -> + let path = Path.of_filename_relative_to_initial_cwd file in + let+ graph = + Memo.dump_cached_graph + ~time_nodes:(Common.dump_memo_graph_with_timing common) + toplevel_cell + in + Graph.serialize graph ~path + ~format:(Common.dump_memo_graph_format common) + (* CR-someday cmoseley: It would be nice to use Persistent to dump a + copy of the graph's internal representation here, so it could be used + without needing to re-run the build*) + in + res) ~finally:(fun () -> Hooks.End_of_build.run (); Fiber.return ()) diff --git a/bin/common.ml b/bin/common.ml index ebd6ad748210..68c98ccd01ea 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -2,6 +2,7 @@ open Stdune module Config = Dune_util.Config module Colors = Dune_rules.Colors module Clflags = Dune_engine.Clflags +module Graph = Dune_graph.Graph module Package = Dune_engine.Package module Profile = Dune_rules.Profile module Term = Cmdliner.Term @@ -39,6 +40,9 @@ type t = ; default_target : Arg.Dep.t (* For build & runtest only *) ; watch : Dune_engine.Watch_mode_config.t ; print_metrics : bool + ; dump_memo_graph_file : string option + ; dump_memo_graph_format : Graph.File_format.t + ; dump_memo_graph_with_timing : bool ; stats_trace_file : string option ; always_show_command_line : bool ; promote_install_files : bool @@ -57,6 +61,12 @@ let watch t = t.watch let print_metrics t = t.print_metrics +let dump_memo_graph_file t = t.dump_memo_graph_file + +let dump_memo_graph_format t = t.dump_memo_graph_format + +let dump_memo_graph_with_timing t = t.dump_memo_graph_with_timing + let file_watcher t = t.file_watcher let default_target t = t.default_target @@ -831,6 +841,31 @@ let term ~default_root_is_cwd = value & flag & info [ "print-metrics" ] ~docs ~doc:"Print out various performance metrics after every build") + and+ dump_memo_graph_file = + Arg.( + value + & opt (some string) None + & info [ "dump-memo-graph" ] ~docs ~docv:"FILE" + ~doc: + "Dumps the dependency graph to a file after the build is complete") + and+ dump_memo_graph_format = + Arg.( + value & opt graph_format Gexf + & info + [ "dump-memo-graph-format" ] + ~docs ~docv:"FORMAT" + ~doc:"File format to be used when dumping dependency graph") + and+ dump_memo_graph_with_timing = + Arg.( + value & flag + & info + [ "dump-memo-graph-with-timing" ] + ~docs + ~doc: + "With $(b,--dump-memo-graph), will re-run each cached node in the \ + Memo graph after building and include the runtime in the output. \ + Since all nodes contain a cached value, this will measure just \ + the runtime of each node") and+ { Options_implied_by_dash_p.root ; only_packages ; ignore_promoted_rules @@ -988,6 +1023,9 @@ let term ~default_root_is_cwd = ; default_target ; watch ; print_metrics + ; dump_memo_graph_file + ; dump_memo_graph_format + ; dump_memo_graph_with_timing ; stats_trace_file ; always_show_command_line ; promote_install_files diff --git a/bin/common.mli b/bin/common.mli index a069354dbfd4..ca6f8178ddea 100644 --- a/bin/common.mli +++ b/bin/common.mli @@ -10,6 +10,12 @@ val stats : t -> Dune_stats.t option val print_metrics : t -> bool +val dump_memo_graph_file : t -> string option + +val dump_memo_graph_format : t -> Dune_graph.Graph.File_format.t + +val dump_memo_graph_with_timing : t -> bool + val watch : t -> Dune_engine.Watch_mode_config.t val file_watcher : t -> Dune_engine.Scheduler.Run.file_watcher diff --git a/bin/dune b/bin/dune index 3975c3f09fa2..c5574907eeb2 100644 --- a/bin/dune +++ b/bin/dune @@ -8,6 +8,7 @@ unix dune_cache dune_cache_storage + dune_graph dune_rules dune_engine dune_util diff --git a/bin/import.ml b/bin/import.ml index bd5266325ab9..d29152d53939 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -29,6 +29,7 @@ module Targets = Dune_engine.Targets module Profile = Dune_rules.Profile module Log = Dune_util.Log module Dune_rpc = Dune_rpc_private +module Graph = Dune_graph.Graph include Common.Let_syntax let in_group (t, info) = (Term.Group.Term t, info) diff --git a/boot/libs.ml b/boot/libs.ml index 1c479bbbd80e..c87fa7fb1a87 100644 --- a/boot/libs.ml +++ b/boot/libs.ml @@ -9,6 +9,7 @@ let local_libraries = Some "Dune_filesystem_stubs", false, None) ; ("vendor/csexp/src", Some "Csexp", false, None) ; ("otherlibs/stdune-unstable", Some "Stdune", false, None) + ; ("src/dune_graph", Some "Dune_graph", false, None) ; ("src/dune_lang", Some "Dune_lang", false, None) ; ("vendor/incremental-cycles/src", Some "Incremental_cycles", false, None) ; ("src/dag", Some "Dag", false, None) diff --git a/src/dune_graph/dune b/src/dune_graph/dune new file mode 100644 index 000000000000..df32820e348f --- /dev/null +++ b/src/dune_graph/dune @@ -0,0 +1,3 @@ +(library + (name dune_graph) + (libraries stdune)) diff --git a/src/dune_graph/dune_graph.ml b/src/dune_graph/dune_graph.ml new file mode 100644 index 000000000000..3154d6a31d5c --- /dev/null +++ b/src/dune_graph/dune_graph.ml @@ -0,0 +1 @@ +module Graph = Graph diff --git a/src/dune_graph/graph.ml b/src/dune_graph/graph.ml new file mode 100644 index 000000000000..faa77eb10679 --- /dev/null +++ b/src/dune_graph/graph.ml @@ -0,0 +1,314 @@ +open Stdune + +module File_format = struct + type t = + | Gexf + | Dot + | Summary + + let conv = + ( (function + | "gexf" -> Ok Gexf + | "dot" -> Ok Dot + | "summary" -> Ok Summary + | s -> Error (`Msg (Format.sprintf "%s is not a valid graph format" s))) + , fun fmt t -> + Format.pp_print_string fmt + (match t with + | Gexf -> "gexf" + | Dot -> "dot" + | Summary -> "summary") ) +end + +module Attribute = struct + type t = + | String of string + | Int of int + | Float of float + | Boolean of bool + + let to_dyn = function + | String s -> Dyn.Variant ("String", [ Dyn.String s ]) + | Int i -> Dyn.Variant ("Int", [ Dyn.Int i ]) + | Float f -> Dyn.Variant ("Float", [ Dyn.Float f ]) + | Boolean b -> Dyn.Variant ("Boolean", [ Dyn.Bool b ]) + + let to_string = function + | String s -> s + | Int i -> Int.to_string i + | Float f -> Float.to_string f + | Boolean b -> Bool.to_string b + + let to_kind_string = function + | String _ -> "string" + | Int _ -> "int" + | Float _ -> "float" + | Boolean _ -> "boolean" +end + +module Node = struct + type t = + { label : string option + ; attributes : Attribute.t Int.Map.t + } + + let to_dyn t = + Dyn.Record + [ ("label", Dyn.Option (Option.map t.label ~f:(fun s -> Dyn.String s))) + ; ("attributes", Int.Map.to_dyn Attribute.to_dyn t.attributes) + ] +end + +module Edge = struct + module T = struct + type t = + { src_id : int + ; dst_id : int + } + + let to_dyn t = + Dyn.Record [ ("src_id", Dyn.Int t.src_id); ("dst_id", Dyn.Int t.dst_id) ] + + let compare a b = + match Int.compare a.src_id b.src_id with + | Eq -> Int.compare a.dst_id b.dst_id + | _ as neq -> neq + end + + include T + module Map = Map.Make (T) + module Set = Set.Make (T) (Map) +end + +type t = + { nodes : Node.t Int.Map.t + ; edges : Edge.Set.t + ; attributes : (int * string) String.Map.t + ; attribute_count : int + } + +let empty = + { nodes = Int.Map.empty + ; edges = Edge.Set.empty + ; attributes = String.Map.empty + ; attribute_count = 0 + } + +let to_dyn t = + Dyn.Record + [ ("nodes", Int.Map.to_dyn Node.to_dyn t.nodes) + ; ("edges", Edge.Set.to_dyn t.edges) + ] + +let add_node ?label t ~id ~attributes = + (* Map attributes, and possibly create a new entry *) + let attributes, attribute_count, node_attributes = + String.Map.foldi attributes + ~init:(t.attributes, t.attribute_count, Int.Map.empty) + ~f:(fun attr_name value (attributes, attribute_count, node_attributes) -> + let value_kind = Attribute.to_kind_string value in + let id, kind, attribute_count = + match String.Map.find attributes attr_name with + | None -> (attribute_count, value_kind, attribute_count + 1) + | Some (id, kind) -> + if not (kind = value_kind) then + failwith + (Printf.sprintf "Attribute %s saw conflicting types %s and %s" + attr_name kind value_kind); + (id, kind, attribute_count) + in + ( String.Map.set attributes attr_name (id, kind) + , attribute_count + , Int.Map.set node_attributes id value )) + in + { t with + nodes = Int.Map.set t.nodes id { label; attributes = node_attributes } + ; attributes + ; attribute_count + } + +let add_edge t ~src_id ~dst_id = + { t with edges = Edge.Set.add t.edges { src_id; dst_id } } + +let has_node t ~id = Int.Map.mem t.nodes id + +let serialize_to_gexf t oc = + output_string oc + {| + + + +|}; + if t.attribute_count > 0 then ( + output_string oc "\n"; + String.Map.iteri t.attributes ~f:(fun name (id, kind) -> + Printf.fprintf oc "\n" + id name kind); + output_string oc "\n" + ); + Int.Map.iteri t.nodes ~f:(fun id node -> + let label = + match node.label with + | None -> "" + | Some label -> Printf.sprintf {| label="%s"|} label + in + if Int.Map.cardinal node.attributes = 0 then + Printf.fprintf oc "\n" id label + else ( + Printf.fprintf oc "\n\n" id label; + Int.Map.iteri node.attributes ~f:(fun attr_id value -> + Printf.fprintf oc "\n" attr_id + (Attribute.to_string value)); + output_string oc "\n\n" + )); + output_string oc "\n\n"; + let _ = + Edge.Set.fold t.edges ~init:0 ~f:(fun edge id -> + Printf.fprintf oc "\n" id + edge.src_id edge.dst_id; + id + 1) + in + output_string oc "\n\n\n" + +let serialize_to_dot t oc = + output_string oc "strict digraph {\n"; + Edge.Set.iter t.edges ~f:(fun edge -> + Printf.fprintf oc "n_%d -> n_%d\n" edge.src_id edge.dst_id); + output_string oc "}\n" + +module Aggregated = struct + type t = + { count : int + ; in_degree : int + ; out_degree : int + ; attributes : Attribute.t Int.Map.t + } +end + +module String_opt_map = Map.Make (struct + type t = string option + + let to_dyn t = Dyn.Option (Option.map t ~f:(fun s -> Dyn.String s)) + + let compare = Option.compare String.compare +end) + +let serialize_summary t oc = + let open Aggregated in + (* CR-someday cmoseley: A memo node is created for each *.all-deps target + which fills up the summary with noise. This is a hacky fix for it right + now, it would be better to find something else to aggregate on or to move + these nodes to a single table since they only have a single entry each *) + let rename_all_deps label = + Option.map label ~f:(fun label -> + if String.is_suffix label ~suffix:".all-deps" then + "*.all-deps" + else + label) + in + let by_label = + Int.Map.fold t.nodes ~init:String_opt_map.empty ~f:(fun node acc -> + let label = rename_all_deps node.label in + let attributes = + Option.value ~default:Int.Map.empty + (Option.map (String_opt_map.find acc label) ~f:(fun agg -> + agg.attributes)) + in + let attributes = + Int.Map.merge attributes node.attributes ~f:(fun _ old_val new_val -> + match (old_val, new_val) with + | None, new_val -> new_val + | old_val, None -> old_val + | Some (Int old_val), Some (Int new_val) -> + Some (Int (old_val + new_val)) + | Some (Float old_val), Some (Float new_val) -> + Some (Float (old_val +. new_val)) + | _, _ -> None) + in + String_opt_map.update acc label ~f:(function + | None -> + Some { count = 1; in_degree = 0; out_degree = 0; attributes } + | Some agg -> Some { agg with count = agg.count + 1; attributes })) + in + let by_label = + Edge.Set.fold t.edges ~init:by_label ~f:(fun edge acc -> + let get_label id = + Option.bind (Int.Map.find t.nodes id) ~f:(fun node -> + rename_all_deps node.label) + in + let src_label = get_label edge.src_id in + let dst_label = get_label edge.dst_id in + let acc = + String_opt_map.update acc src_label + ~f: + (Option.map ~f:(fun agg -> + { agg with out_degree = agg.out_degree + 1 })) + in + let acc = + String_opt_map.update acc dst_label + ~f: + (Option.map ~f:(fun agg -> + { agg with in_degree = agg.in_degree + 1 })) + in + acc) + in + Printf.fprintf oc "%14s %14s %14s %14s %14s %s\n" "Count" "Edges in" + "Edges out" "Time (s)" "Avg time (ms)" "Label"; + String_opt_map.to_list by_label + |> List.sort ~compare:(fun (_, a) (_, b) -> Int.compare b.count a.count) + |> List.iter ~f:(fun (label, agg) -> + let label = + match label with + | None -> "" + | Some label -> Printf.sprintf "\"%s\"" label + in + let runtime, avg_runtime = + Option.bind (String.Map.find t.attributes "runtime") + ~f:(fun (id, _) -> + Option.bind (Int.Map.find agg.attributes id) ~f:(fun value -> + match value with + | Float runtime -> + let avg_ms = 1000. *. runtime /. float_of_int agg.count in + Some + ( Printf.sprintf "%.4f" runtime + , Printf.sprintf "%.4f" avg_ms ) + | String _ + | Int _ + | Boolean _ -> + None)) + |> Option.value ~default:("", "") + in + Printf.fprintf oc "%14d %14d %14d %14s %14s %s\n" agg.count + agg.in_degree agg.out_degree runtime avg_runtime label); + Printf.fprintf oc "nodes: %d edges: %d\n" (Int.Map.cardinal t.nodes) + (Edge.Set.cardinal t.edges) + +let serialize_to_output_channel t oc ~format = + match (format : File_format.t) with + | Gexf -> serialize_to_gexf t oc + | Dot -> serialize_to_dot t oc + | Summary -> serialize_summary t oc + +let serialize t ~path ~format = + Io.with_file_out path ~f:(serialize_to_output_channel t ~format) + +let print t ~format = serialize_to_output_channel t Stdlib.stdout ~format + +module For_tests = struct + let print t ~format ~opaque_attributes = + let opaque_graph = + { t with + nodes = + Int.Map.map t.nodes ~f:(fun node -> + { node with + attributes = + Int.Map.mapi node.attributes ~f:(fun id attr -> + if Int.Set.mem opaque_attributes id then + Attribute.String "" + else + attr) + }) + } + in + print opaque_graph ~format +end diff --git a/src/dune_graph/graph.mli b/src/dune_graph/graph.mli new file mode 100644 index 000000000000..0382f20ae011 --- /dev/null +++ b/src/dune_graph/graph.mli @@ -0,0 +1,67 @@ +open Stdune + +module File_format : sig + type t = + | Gexf + | Dot + | Summary + + val conv : + (string -> (t, [> `Msg of string ]) result) + * (Format.formatter -> t -> unit) +end + +module Attribute : sig + type t = + | String of string + | Int of int + | Float of float + | Boolean of bool + + val to_dyn : t -> Dyn.t +end + +type t + +val to_dyn : t -> Dyn.t + +(* CR-someday cmoseley: This interface isn't ideal as users will need to supply + IDs manually, which could mean overwriting nodes or adding edges between + non-existent nodes. However, it is currently needed for Memo to associate + dep_nodes with nodes in this graph. It would be nice to refactor it to be + more safe + + Another improvement would be better types for attributes. Currently, typing + is only enforced by comparing value types when creating a node and raising if + an attribute is inconsistent within a graph. It would be nice to enforce this + somehow using the type system *) + +(** An empty graph *) +val empty : t + +(** Adds a node to this graph with an ID, attributes, and optionally a label. + attributes is a map from attribute names to values. This function will fail + if an attribute is provided with the same name but different kind of value + to a previously provided attribute in the graph *) +val add_node : + ?label:string -> t -> id:int -> attributes:Attribute.t String.Map.t -> t + +(** Add an edge between node with src_id and node with dst_id *) +val add_edge : t -> src_id:int -> dst_id:int -> t + +(** Whether this graph contains a node with the given id *) +val has_node : t -> id:int -> bool + +(** Serializes this graph to a file using the given format *) +val serialize : t -> path:Path.t -> format:File_format.t -> unit + +(** Prints this graph to stdout using the given file format *) +val print : t -> format:File_format.t -> unit + +module For_tests : sig + (** opaque_attributes is a set of integers representing ids of attributes + which should not be printed out in tests, perhaps because they are likely + to change between runs. For example, measured runtime. These attributes + will be replaced with the string *) + val print : t -> format:File_format.t -> opaque_attributes:Int.Set.t -> unit +end diff --git a/src/memo/dune b/src/memo/dune index 59949ec084c1..c53fc7ecdb12 100644 --- a/src/memo/dune +++ b/src/memo/dune @@ -1,4 +1,4 @@ (library (name memo) - (libraries stdune dyn dune_lang dag fiber) + (libraries stdune dyn dune_graph dune_lang dag fiber) (synopsis "Function memoizer")) diff --git a/src/memo/memo.ml b/src/memo/memo.ml index 4e6aa3ad2bbf..3212da04156c 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -1,5 +1,6 @@ open! Stdune open Fiber.O +module Graph = Dune_graph.Graph module Debug = struct let track_locations_of_lazy_values = ref false @@ -1339,6 +1340,47 @@ end let exec (type i o) (t : (i, o) t) i = Exec.exec_dep_node (dep_node t i) +let dump_cached_graph ?(on_not_cached = `Raise) ?(time_nodes = false) cell = + let rec collect_graph (Dep_node.T dep_node) graph : Graph.t Fiber.t = + let src_id = Id.to_int dep_node.without_state.id in + match get_cached_value_in_current_run dep_node with + | Some cached -> + let* attributes = + if time_nodes then + let start = Unix.gettimeofday () in + (* CR-someday cmoseley: We could record errors here and include them + as part of the graph. *) + let+ (_ : (_, Collect_errors_monoid.t) result) = + report_and_collect_errors (fun () -> + dep_node.without_state.spec.f dep_node.without_state.input) + in + let runtime = Unix.gettimeofday () -. start in + String.Map.of_list_exn [ ("runtime", Graph.Attribute.Float runtime) ] + else + Fiber.return String.Map.empty + in + let graph = + Graph.add_node graph ~id:src_id ?label:dep_node.without_state.spec.name + ~attributes + in + List.fold_left (Deps.to_list cached.deps) ~init:(Fiber.return graph) + ~f:(fun graph (Dep_node.T dst_node as packed) -> + let* graph = graph in + let dst_id = Id.to_int dst_node.without_state.id in + let graph = Graph.add_edge graph ~src_id ~dst_id in + if Graph.has_node graph ~id:dst_id then + Fiber.return graph + else + collect_graph packed graph) + | None -> ( + match on_not_cached with + | `Raise -> failwith "Memo graph contains uncached nodes" + | `Ignore -> Fiber.return graph) + in + Error_handler.with_error_handler + (fun (_ : Exn_with_backtrace.t) -> Fiber.return ()) + (fun () -> collect_graph (Dep_node.T cell) Graph.empty) + let get_call_stack = Call_stack.get_call_stack_without_state module Invalidation = struct diff --git a/src/memo/memo.mli b/src/memo/memo.mli index 9b403b09920f..a6c93df7371a 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -351,6 +351,13 @@ val lazy_cell : -> (unit -> 'a Build.t) -> (unit, 'a) Cell.t +(** Returns the cached dependency graph discoverable from the specified node *) +val dump_cached_graph : + ?on_not_cached:[ `Ignore | `Raise ] + -> ?time_nodes:bool + -> ('i, 'o) Cell.t + -> Dune_graph.Graph.t Fiber.t + module Lazy : sig type 'a t diff --git a/test/blackbox-tests/test-cases/dump-graph.t/run.t b/test/blackbox-tests/test-cases/dump-graph.t/run.t new file mode 100644 index 000000000000..54e06a5ab9e2 --- /dev/null +++ b/test/blackbox-tests/test-cases/dump-graph.t/run.t @@ -0,0 +1,28 @@ + $ cat > dune-project < (lang dune 2.0) + > EOF + + $ cat > dune << EOF + > (rule (target a) (action (bash "echo a > a"))) + > EOF + +Graph in GEXF format with actual nodes and edges elided + + $ dune build --dump-memo-graph graph.gexf --dump-memo-graph-format gexf a + $ cat graph.gexf | grep -v ' + + + + + + + + + +Graph in dot format with actual nodes and edges elided + + $ dune build --dump-memo-graph graph.vg --dump-memo-graph-format dot a + $ cat graph.vg | grep -v 'n_[0-9]\+ -> n_[0-9]\+' + strict digraph { + } diff --git a/test/expect-tests/memo/graph_dump/dump_graph_tests.ml b/test/expect-tests/memo/graph_dump/dump_graph_tests.ml new file mode 100644 index 000000000000..093dea99a493 --- /dev/null +++ b/test/expect-tests/memo/graph_dump/dump_graph_tests.ml @@ -0,0 +1,183 @@ +open Stdune +open Memo +open Memo.Build.O +module Graph = Dune_graph.Graph + +module Scheduler = struct + let t = Test_scheduler.create () + + let yield () = Test_scheduler.yield t + + let run f = Test_scheduler.run t f +end + +(* to run a computation *) +let run m = Scheduler.run (Memo.Build.run m) + +let run_memo f v = + try run (Memo.exec f v) with + | Memo.Error.E _ -> () + +let a = Memo.create "A" ~input:(module Unit) (fun () -> Build.return ()) + +let b = + Memo.create "B" + ~input:(module Unit) + (fun () -> + let+ () = Memo.exec a () in + ()) + +let c = + Memo.create "C" + ~input:(module Unit) + (fun () -> + let+ () = Memo.exec a () in + ()) + +let d = + Memo.create "D" + ~input:(module Unit) + (fun () -> + let* () = Memo.exec b () in + let+ () = Memo.exec c () in + ()) + +let e = + Memo.create "E" + ~input:(module Unit) + (fun () -> + let* () = Memo.exec d () in + failwith "Oops, error!") + +let () = run_memo e () + +let%expect_test _ = + let graph = Scheduler.run (Memo.dump_cached_graph (Memo.cell d ())) in + Graph.print graph ~format:Graph.File_format.Gexf; + [%expect + {| + + + + + + + + + + + + + + + + + |}] + +let%expect_test _ = + let graph = Scheduler.run (Memo.dump_cached_graph (Memo.cell d ())) in + Graph.print graph ~format:Graph.File_format.Dot; + [%expect + {| + strict digraph { + n_1 -> n_2 + n_1 -> n_4 + n_2 -> n_3 + n_4 -> n_3 + } |}] + +let%expect_test _ = + let graph = + Scheduler.run (Memo.dump_cached_graph ~time_nodes:true (Memo.cell d ())) + in + Graph.For_tests.print graph ~format:Graph.File_format.Gexf + ~opaque_attributes:(Int.Set.singleton 0); + [%expect + {| + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + |}] + +let%expect_test _ = + let graph = + Scheduler.run (Memo.dump_cached_graph ~time_nodes:true (Memo.cell e ())) + in + Graph.For_tests.print graph ~format:Graph.File_format.Gexf + ~opaque_attributes:(Int.Set.singleton 0); + [%expect + {| + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + |}] diff --git a/test/expect-tests/memo/graph_dump/dune b/test/expect-tests/memo/graph_dump/dune new file mode 100644 index 000000000000..18534e3288b3 --- /dev/null +++ b/test/expect-tests/memo/graph_dump/dune @@ -0,0 +1,16 @@ +(library + (name dune_memo_graph_dump_tests) + (inline_tests) + (libraries + stdune + dune_graph + memo + test_scheduler + ;; This is because of the (implicit_transitive_deps false) + ;; in dune-project + ppx_expect.config_types + ppx_expect.common + base + ppx_inline_test.config) + (preprocess + (pps ppx_expect))) From 21268b29bcc2257039c404c2ca0912d0594ec8a9 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Fri, 29 Oct 2021 14:43:02 +0100 Subject: [PATCH 06/32] Factor target promotion logic out of build_system.ml (#5066) The [build_system.ml] module is too large, we need to gradually split it into pieces. This PR factors out a good chunk of target promotion logic, also hiding some unnecessary internal details. This is motivated by the fact that I'm adding even more target promotion logic to cope with directory targets. There is no behaviour change. Signed-off-by: Andrey Mokhov --- bin/clean.ml | 2 +- otherlibs/stdune-unstable/path.ml | 4 + otherlibs/stdune-unstable/path_intf.ml | 4 + src/dune_engine/build_system.ml | 205 +------------------------ src/dune_engine/build_system.mli | 4 - src/dune_engine/dune_engine.ml | 1 + src/dune_engine/promotion.ml | 2 +- src/dune_engine/promotion.mli | 3 + src/dune_engine/target_promotion.ml | 193 +++++++++++++++++++++++ src/dune_engine/target_promotion.mli | 22 +++ 10 files changed, 234 insertions(+), 206 deletions(-) create mode 100644 src/dune_engine/target_promotion.ml create mode 100644 src/dune_engine/target_promotion.mli diff --git a/bin/clean.ml b/bin/clean.ml index f4f1561e460a..dd2c63601b58 100644 --- a/bin/clean.ml +++ b/bin/clean.ml @@ -18,7 +18,7 @@ let command = useless but with some FS this also causes [dune clean] to fail (cf https://github.com/ocaml/dune/issues/2964). *) let _config = Common.init common ~log_file:No_log_file in - Build_system.files_in_source_tree_to_delete () + Dune_engine.Target_promotion.files_in_source_tree_to_delete () |> Path.Set.iter ~f:Path.unlink_no_err; Path.rm_rf Path.build_dir in diff --git a/otherlibs/stdune-unstable/path.ml b/otherlibs/stdune-unstable/path.ml index d905754ac1d4..519d9fdd2b3f 100644 --- a/otherlibs/stdune-unstable/path.ml +++ b/otherlibs/stdune-unstable/path.ml @@ -130,6 +130,8 @@ end = struct let mkdir_p ?perms path = ignore (Fpath.mkdir_p ?perms (to_string path) : Fpath.mkdir_p_result) + let unlink_no_err t = Fpath.unlink_no_err (to_string t) + let extension t = Filename.extension (to_string t) let split_extension t = @@ -248,6 +250,8 @@ end = struct | None -> Some root | Some i -> Some (make (String.take t i)) + let unlink_no_err t = Fpath.unlink_no_err (to_string t) + let basename t = if is_root t then Code_error.raise "Path.Local.basename called on the root" [] diff --git a/otherlibs/stdune-unstable/path_intf.ml b/otherlibs/stdune-unstable/path_intf.ml index a5318d53c28b..462ed6f39575 100644 --- a/otherlibs/stdune-unstable/path_intf.ml +++ b/otherlibs/stdune-unstable/path_intf.ml @@ -52,6 +52,8 @@ module type S = sig val parent_exn : t -> t val parent : t -> t option + + val unlink_no_err : t -> unit end (** [Unspecified.w] is a type-level placeholder of an unspecified path. (see @@ -136,4 +138,6 @@ module type Local_gen = sig module L : sig val relative : ?error_loc:Loc0.t -> 'w t -> string list -> 'w t end + + val unlink_no_err : 'w t -> unit end diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 50786373869d..55076cf9a27d 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -47,77 +47,6 @@ end = struct [ Pp.textf "%S does not exist" (Path.to_string_maybe_quoted path) ]) end -(* [Promoted_to_delete] is used mostly to implement [dune clean]. It is an - imperfect heuristic, in particular it can go wrong if: - - - the user deletes .to-delete-in-source-tree file - - - the user edits a previously promoted file with the intention of keeping it - in the source tree, or creates a new file with the same name *) -module Promoted_to_delete : sig - val add : Path.t -> unit - - val remove : Path.t -> unit - - val mem : Path.t -> bool - - val get_db : unit -> Path.Set.t -end = struct - module P = Dune_util.Persistent.Make (struct - type t = Path.Set.t - - let name = "PROMOTED-TO-DELETE" - - let version = 1 - - let to_dyn = Path.Set.to_dyn - end) - - let fn = Path.relative Path.build_dir ".to-delete-in-source-tree" - - (* [db] is used to accumulate promoted files from rules. *) - let db = lazy (ref (Option.value ~default:Path.Set.empty (P.load fn))) - - let get_db () = !(Lazy.force db) - - let set_db new_db = Lazy.force db := new_db - - let needs_dumping = ref false - - let modify_db f = - match f (get_db ()) with - | None -> () - | Some new_db -> - set_db new_db; - needs_dumping := true - - let add p = - modify_db (fun db -> - if Path.Set.mem db p then - None - else - Some (Path.Set.add db p)) - - let remove p = - modify_db (fun db -> - if Path.Set.mem db p then - Some (Path.Set.remove db p) - else - None) - - let dump () = - if !needs_dumping && Path.build_dir_exists () then ( - needs_dumping := false; - get_db () |> P.dump fn - ) - - let mem p = Path.Set.mem !(Lazy.force db) p - - let () = Hooks.End_of_build.always dump -end - -let files_in_source_tree_to_delete () = Promoted_to_delete.get_db () - module Loaded = struct type rules_here = { by_file_targets : Rule.t Path.Build.Map.t @@ -542,7 +471,7 @@ let () = Hooks.End_of_build.always (fun () -> let fns = !pending_targets in pending_targets := Path.Build.Set.empty; - Path.Build.Set.iter fns ~f:(fun p -> Path.unlink_no_err (Path.build p))) + Path.Build.Set.iter fns ~f:(fun p -> Path.Build.unlink_no_err p)) let compute_target_digests targets = let file_targets, (_ignored_dir_targets : unit list) = @@ -1004,40 +933,6 @@ end = struct ~subdir:(Path.Build.basename dir) end - (* TODO: Delete this step after users of dune <2.8 are sufficiently rare. This - step is sketchy because it's using the [Promoted_to_delete] database and - that can get out of date (see a comment on [Promoted_to_delete]), so we - should not widen the scope of it too much. *) - let delete_stale_dot_merlin_file ~dir ~source_files_to_ignore = - (* If a [.merlin] file is present in the [Promoted_to_delete] set but not in - the [Source_files_to_ignore] that means the rule that ordered its - promotion is no more valid. This would happen when upgrading to Dune 2.8 - from earlier version without and building uncleaned projects. We delete - these leftover files here. *) - let merlin_file = ".merlin" in - let source_dir = Path.Build.drop_build_context_exn dir in - let merlin_in_src = Path.Source.(relative source_dir merlin_file) in - let source_files_to_ignore = - if - Promoted_to_delete.mem (Path.source merlin_in_src) - && not (Path.Source.Set.mem source_files_to_ignore merlin_in_src) - then ( - let path = Path.source merlin_in_src in - Log.info - [ Pp.textf "Deleting left-over Merlin file %s.\n" - (Path.to_string path) - ]; - (* We remove the file from the promoted database *) - Promoted_to_delete.remove path; - Path.unlink_no_err path; - (* We need to keep ignoring the .merlin file for that build or Dune will - attempt to copy it and fail because it has been deleted *) - Path.Source.Set.add source_files_to_ignore merlin_in_src - ) else - source_files_to_ignore - in - source_files_to_ignore - let load_dir_step2_exn t ~dir ~context_or_install ~sub_dir = let sub_dir_components = Path.Source.explode sub_dir in (* Load all the rules *) @@ -1111,7 +1006,7 @@ end = struct |> Path.Source.Set.of_list_map ~f:Path.Build.drop_build_context_exn in let source_files_to_ignore = - delete_stale_dot_merlin_file ~dir ~source_files_to_ignore + Target_promotion.delete_stale_dot_merlin_file ~dir ~source_files_to_ignore in (* Take into account the source files *) let to_copy, source_dirs = @@ -2015,99 +1910,9 @@ end = struct | (Standard | Fallback | Ignore_source_files), _ | Promote _, Some Never -> Fiber.return () - | Promote { lifetime; into; only }, (Some Automatically | None) -> - (* CR-someday amokhov: Don't ignore directory targets. *) - let file_targets = - Targets.map targets ~f:(fun ~files ~dirs -> - ignore dirs; - files) - in - Fiber.parallel_iter_set - (module Path.Build.Set) - file_targets - ~f:(fun target -> - let consider_for_promotion = - match only with - | None -> true - | Some pred -> - Predicate_lang.Glob.exec pred - (Path.reach (Path.build target) ~from:(Path.build dir)) - ~standard:Predicate_lang.any - in - match consider_for_promotion with - | false -> Fiber.return () - | true -> - let in_source_tree = - Path.Build.drop_build_context_exn target - in - let in_source_tree = - match into with - | None -> in_source_tree - | Some { loc; dir } -> - Path.Source.relative - (Path.Source.relative - (Path.Source.parent_exn in_source_tree) - dir ~error_loc:loc) - (Path.Source.basename in_source_tree) - in - let* () = - let dir = Path.Source.parent_exn in_source_tree in - Memo.Build.run (Source_tree.find_dir dir) >>| function - | Some _ -> () - | None -> - let loc = - match into with - | Some into -> into.loc - | None -> - Code_error.raise - "promoting into directory that does not exist" - [ ( "in_source_tree" - , Path.Source.to_dyn in_source_tree ) - ] - in - User_error.raise ~loc - [ Pp.textf "directory %S does not exist" - (Path.Source.to_string_maybe_quoted dir) - ] - in - let dst = in_source_tree in - let in_source_tree = Path.source in_source_tree in - let* is_up_to_date = - Memo.Build.run - (let open Memo.Build.O in - Fs_memo.path_digest in_source_tree - >>| Cached_digest.Digest_result.to_option - >>| function - | None -> false - | Some in_source_tree_digest -> ( - match - Cached_digest.build_file target - |> Cached_digest.Digest_result.to_option - with - | None -> - (* CR-someday amokhov: We couldn't digest the target - so something happened to it. Right now, we skip the - promotion in this case, but we could perhaps delete - the corresponding path in the source tree. *) - true - | Some in_build_dir_digest -> - Digest.equal in_build_dir_digest in_source_tree_digest - )) - in - if is_up_to_date then - Fiber.return () - else ( - if lifetime = Until_clean then - Promoted_to_delete.add in_source_tree; - let* () = Scheduler.ignore_for_watch in_source_tree in - (* The file in the build directory might be read-only if it - comes from the shared cache. However, we want the file in - the source tree to be writable by the user, so we - explicitly set the user writable bit. *) - let chmod n = n lor 0o200 in - Path.unlink_no_err (Path.source dst); - t.promote_source ~src:target ~dst ~chmod context - )) + | Promote promote, (Some Automatically | None) -> + Target_promotion.promote ~dir ~targets ~promote + ~promote_source:(fun ~chmod -> t.promote_source ~chmod context) in t.rule_done <- t.rule_done + 1; let+ () = diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli index ff9a11b93d82..292ce4268ef6 100644 --- a/src/dune_engine/build_system.mli +++ b/src/dune_engine/build_system.mli @@ -189,10 +189,6 @@ val get_alias_definition : (** List of all buildable targets. *) val all_targets : unit -> Path.Build.Set.t Memo.Build.t -(** The set of files that were created in the source tree and need to be - deleted. *) -val files_in_source_tree_to_delete : unit -> Path.Set.t - (** {2 Running a build} *) val run : diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index 45db9fe7fd60..ff7bf4e5ded0 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -36,6 +36,7 @@ module Dpath = Dpath module Rules = Rules module Rule = Rule module Targets = Targets +module Target_promotion = Target_promotion module Build_context = Build_context module Build_system = Build_system module Cram_test = Cram_test diff --git a/src/dune_engine/promotion.ml b/src/dune_engine/promotion.ml index 742005f27a49..d9319f315f49 100644 --- a/src/dune_engine/promotion.ml +++ b/src/dune_engine/promotion.ml @@ -62,7 +62,7 @@ module File = struct db := { src; staging = Some staging; dst = source_file } :: !db let do_promote ~correction_file ~dst = - Path.unlink_no_err (Path.source dst); + Path.Source.unlink_no_err dst; let chmod perms = perms lor 0o200 in Io.copy_file ~chmod ~src:(Path.build correction_file) diff --git a/src/dune_engine/promotion.mli b/src/dune_engine/promotion.mli index 411710ab85f9..9101c29c6e70 100644 --- a/src/dune_engine/promotion.mli +++ b/src/dune_engine/promotion.mli @@ -1,3 +1,6 @@ +(** This module is responsible for handling [diff]-related file promotions. + + See [Target_promotion] for the logic that handles promotion of rule targets. *) open! Stdune module Annot : sig diff --git a/src/dune_engine/target_promotion.ml b/src/dune_engine/target_promotion.ml new file mode 100644 index 000000000000..0c76db981879 --- /dev/null +++ b/src/dune_engine/target_promotion.ml @@ -0,0 +1,193 @@ +open! Stdune +open! Import + +(* [To_delete] is used mostly to implement [dune clean]. It is an imperfect + heuristic, in particular it can go wrong if: + + - the user deletes .to-delete-in-source-tree file + + - the user edits a previously promoted file with the intention of keeping it + in the source tree, or creates a new file with the same name. *) +module To_delete = struct + module P = Dune_util.Persistent.Make (struct + (* CR-someday amokhov: This should really be a [Path.Source.Set.t] but + changing it now would require bumping the [version]. Should we do it? *) + type t = Path.Set.t + + let name = "PROMOTED-TO-DELETE" + + let version = 1 + + let to_dyn = Path.Set.to_dyn + end) + + let fn = Path.relative Path.build_dir ".to-delete-in-source-tree" + + (* [db] is used to accumulate promoted files from rules. *) + let db = lazy (ref (Option.value ~default:Path.Set.empty (P.load fn))) + + let get_db () = !(Lazy.force db) + + let set_db new_db = Lazy.force db := new_db + + let needs_dumping = ref false + + let modify_db f = + match f (get_db ()) with + | None -> () + | Some new_db -> + set_db new_db; + needs_dumping := true + + let add p = + let p = Path.source p in + modify_db (fun db -> + if Path.Set.mem db p then + None + else + Some (Path.Set.add db p)) + + let remove p = + let p = Path.source p in + modify_db (fun db -> + if Path.Set.mem db p then + Some (Path.Set.remove db p) + else + None) + + let dump () = + if !needs_dumping && Path.build_dir_exists () then ( + needs_dumping := false; + get_db () |> P.dump fn + ) + + let mem p = + let p = Path.source p in + Path.Set.mem !(Lazy.force db) p + + let () = Hooks.End_of_build.always dump +end + +let files_in_source_tree_to_delete () = To_delete.get_db () + +(* TODO: Delete this step after users of Dune <2.8 are sufficiently rare. This + step is sketchy because it's using the [To_delete] database and that can get + out of date (see a comment on [To_delete]), so we should not widen the scope + of it too much. *) +let delete_stale_dot_merlin_file ~dir ~source_files_to_ignore = + (* If a [.merlin] file is present in the [To_delete] set but not in the + [Source_files_to_ignore] that means the rule that ordered its promotion is + no more valid. This would happen when upgrading to Dune 2.8 from earlier + version without and building uncleaned projects. We delete these leftover + files here. *) + let merlin_file = ".merlin" in + let source_dir = Path.Build.drop_build_context_exn dir in + let merlin_in_src = Path.Source.(relative source_dir merlin_file) in + let source_files_to_ignore = + if + To_delete.mem merlin_in_src + && not (Path.Source.Set.mem source_files_to_ignore merlin_in_src) + then ( + Log.info + [ Pp.textf "Deleting left-over Merlin file %s.\n" + (Path.Source.to_string merlin_in_src) + ]; + (* We remove the file from the promoted database *) + To_delete.remove merlin_in_src; + Path.Source.unlink_no_err merlin_in_src; + (* We need to keep ignoring the .merlin file for that build or Dune will + attempt to copy it and fail because it has been deleted *) + Path.Source.Set.add source_files_to_ignore merlin_in_src + ) else + source_files_to_ignore + in + source_files_to_ignore + +let promote ~dir ~targets ~promote ~promote_source = + let open Fiber.O in + let { Rule.Promote.lifetime; only; into; _ } = promote in + (* CR-someday amokhov: Don't ignore directory targets. *) + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + ignore dirs; + files) + in + Fiber.parallel_iter_set + (module Path.Build.Set) + file_targets + ~f:(fun target -> + let consider_for_promotion = + match only with + | None -> true + | Some pred -> + Predicate_lang.Glob.exec pred + (Path.reach (Path.build target) ~from:(Path.build dir)) + ~standard:Predicate_lang.any + in + match consider_for_promotion with + | false -> Fiber.return () + | true -> + let in_source_tree = Path.Build.drop_build_context_exn target in + let in_source_tree = + match into with + | None -> in_source_tree + | Some { loc; dir } -> + Path.Source.relative + (Path.Source.relative + (Path.Source.parent_exn in_source_tree) + dir ~error_loc:loc) + (Path.Source.basename in_source_tree) + in + let* () = + let dir = Path.Source.parent_exn in_source_tree in + Memo.Build.run (Source_tree.find_dir dir) >>| function + | Some _ -> () + | None -> + let loc = + match into with + | Some into -> into.loc + | None -> + Code_error.raise "promoting into directory that does not exist" + [ ("in_source_tree", Path.Source.to_dyn in_source_tree) ] + in + User_error.raise ~loc + [ Pp.textf "directory %S does not exist" + (Path.Source.to_string_maybe_quoted dir) + ] + in + let dst = in_source_tree in + let in_source_tree = Path.source in_source_tree in + let* is_up_to_date = + Memo.Build.run + (let open Memo.Build.O in + Fs_memo.path_digest in_source_tree + >>| Cached_digest.Digest_result.to_option + >>| function + | None -> false + | Some in_source_tree_digest -> ( + match + Cached_digest.build_file target + |> Cached_digest.Digest_result.to_option + with + | None -> + (* CR-someday amokhov: We couldn't digest the target so + something happened to it. Right now, we skip the promotion in + this case, but we could perhaps delete the corresponding path + in the source tree. *) + true + | Some in_build_dir_digest -> + Digest.equal in_build_dir_digest in_source_tree_digest)) + in + if is_up_to_date then + Fiber.return () + else ( + if lifetime = Until_clean then To_delete.add dst; + let* () = Scheduler.ignore_for_watch in_source_tree in + (* The file in the build directory might be read-only if it comes from + the shared cache. However, we want the file in the source tree to + be writable by the user, so we explicitly set the user writable + bit. *) + let chmod n = n lor 0o200 in + Path.Source.unlink_no_err dst; + promote_source ~chmod ~src:target ~dst + )) diff --git a/src/dune_engine/target_promotion.mli b/src/dune_engine/target_promotion.mli new file mode 100644 index 000000000000..48245de7ff75 --- /dev/null +++ b/src/dune_engine/target_promotion.mli @@ -0,0 +1,22 @@ +(** Promoting rule targets to the source tree. *) + +open! Stdune + +val promote : + dir:Path.Build.t + -> targets:Targets.t + -> promote:Rule.Promote.t + -> promote_source: + ( chmod:(int -> int) + -> src:Path.Build.t + -> dst:Path.Source.t + -> unit Fiber.t) + -> unit Fiber.t + +(** The set of files created in the source tree that need to be deleted. *) +val files_in_source_tree_to_delete : unit -> Path.Set.t + +val delete_stale_dot_merlin_file : + dir:Path.Build.t + -> source_files_to_ignore:Path.Source.Set.t + -> Path.Source.Set.t From 482b4f818857b35e5114498fa63012d13a6d84fd Mon Sep 17 00:00:00 2001 From: Callum Moseley Date: Fri, 29 Oct 2021 17:45:27 +0100 Subject: [PATCH 07/32] Restart build system with no invalidation to inform RPC clients when skipping a rebuild due to eager cutoff (#5067) Signed-off-by: Callum Moseley --- bin/import.ml | 1 + src/dune_engine/scheduler.ml | 28 ++++++++++++++++++++++++---- src/dune_engine/scheduler.mli | 1 + 3 files changed, 26 insertions(+), 4 deletions(-) diff --git a/bin/import.ml b/bin/import.ml index d29152d53939..477fef5e44b5 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -80,6 +80,7 @@ module Scheduler = struct | Scheduler.Run.Event.Tick -> Console.Status_line.refresh () | Source_files_changed { details_hum } -> maybe_clear_screen ~details_hum dune_config + | Skipped_restart -> () | Build_interrupted -> Console.Status_line.set (Live diff --git a/src/dune_engine/scheduler.ml b/src/dune_engine/scheduler.ml index f99f89a16297..25f8948b9437 100644 --- a/src/dune_engine/scheduler.ml +++ b/src/dune_engine/scheduler.ml @@ -732,6 +732,7 @@ module Handler = struct type t = | Tick | Source_files_changed of { details_hum : string list } + | Skipped_restart | Build_interrupted | Build_finish of build_result end @@ -1007,8 +1008,20 @@ end = struct | (Sync : Event.build_input_change) -> true | _ -> false) in + (* CR-someday cmoseley: This can probably be simplified now that we pass + empty invalidations on, but the logic of have_sync isn't clear to me *) match Memo.Invalidation.is_empty invalidation && not have_sync with - | true -> iter t (* Ignore the event *) + | true -> ( + match t.status with + (* CR-someday cmoseley: This works for what we want (to see a skipped + restart due to eager cutoff in RPC clients), however it feels a bit + odd, in that we are restarting the build system for the sole purpose + of sending instant Start and Finish messages *) + + (* We still send the invalidation to surface to users and RPC clients + that we saw a change, but are ignoring it *) + | Waiting_for_file_changes ivar -> Fill (ivar, invalidation) + | _ -> iter t) | false -> ( match t.status with | Shutting_down -> iter t @@ -1135,7 +1148,11 @@ module Run = struct let poll_iter t step = (match t.status with - | Standing_by invalidations -> Memo.reset invalidations + | Standing_by invalidations -> + if Memo.Invalidation.is_empty invalidations then + Memo.Perf_counters.reset () + else + Memo.reset invalidations | _ -> Code_error.raise "[poll_iter]: expected the build status [Standing_by]" []); t.status <- Building; @@ -1195,8 +1212,11 @@ module Run = struct t.status <- Waiting_for_file_changes ivar; let* invalidations = Fiber.Ivar.read ivar in t.status <- Standing_by invalidations; - let details_hum = Memo.Invalidation.details_hum invalidations in - t.handler t.config (Source_files_changed { details_hum }); + (if Memo.Invalidation.is_empty invalidations then + t.handler t.config Skipped_restart + else + let details_hum = Memo.Invalidation.details_hum invalidations in + t.handler t.config (Source_files_changed { details_hum })); Fiber.return Proceed in Fiber.return (step, handle_outcome)) diff --git a/src/dune_engine/scheduler.mli b/src/dune_engine/scheduler.mli index 453189066fc3..bc8edbca3554 100644 --- a/src/dune_engine/scheduler.mli +++ b/src/dune_engine/scheduler.mli @@ -44,6 +44,7 @@ module Run : sig type t = | Tick | Source_files_changed of { details_hum : string list } + | Skipped_restart | Build_interrupted | Build_finish of build_result end From c010be968c0831dd687e7ee07220deef8e6956b1 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 27 Oct 2021 14:58:32 -0600 Subject: [PATCH 08/32] refactor: remove private function from module sig Signed-off-by: Rudi Grinberg ps-id: 1335FC20-26D5-463F-A7ED-2E6825A77D05 --- src/dune_rules/dune_file.mli | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/dune_rules/dune_file.mli b/src/dune_rules/dune_file.mli index a6cbb3fb70b2..112c5adb8bba 100644 --- a/src/dune_rules/dune_file.mli +++ b/src/dune_rules/dune_file.mli @@ -449,19 +449,6 @@ module Stanzas : sig [ast] according to the syntax given by [kind] in the context of the [project] *) val of_ast : Dune_project.t -> Dune_lang.Ast.t -> Stanza.t list - - (** [parse ~file ~kind project stanza_exprs] is a list of [Stanza.t]s derived - from decoding the [stanza_exprs] from [Dune_lang.Ast.t]s to [Stanza.t]s. - - [file] is used to check for illegal recursive file inclusions and to - anchor file includes given as relative paths. - - The stanzas are parsed in the context of the dune [project]. - - The syntax [kind] determines whether the expected syntax is the - depreciated jbuilder syntax or the version of Dune syntax specified by the - current [project]. *) - val parse : file:Path.Source.t -> Dune_project.t -> Dune_lang.Ast.t list -> t end (** A fully evaluated dune file *) From dbd5dabb8d531118072c0000f573a8a0e62f46e7 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 27 Oct 2021 22:13:20 -0600 Subject: [PATCH 09/32] fix: replace parallel_map ~f:Fun.id with all Signed-off-by: Rudi Grinberg --- src/dune_rules/install_rules.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 7ba990cd951a..103b2b03a938 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -371,7 +371,7 @@ end = struct stanza_to_entries ~sctx ~dir ~scope ~expander stanza in named_entries :: acc) - |> Memo.Build.parallel_map ~f:Fun.id + |> Memo.Build.all in List.fold_left l ~init ~f:(fun acc named_entries -> match named_entries with From 0250e37c0e46ba53841bccbdf777a9b558be9bea Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Mon, 1 Nov 2021 15:39:51 +0000 Subject: [PATCH 10/32] Refactor and add more docs to target promotion (#5068) This PR does a few things without changing existing behaviour: * Instead of recomputing target digests, we reuse the digests that are already available after executing a rule. This is useful for an upcoming PR that implements promotion for directory targets (we won't need to recursively traverse the directories again). * Add a few comments documenting ideas for further improvement. * Add a test to ensure that promoted targets are restored when deleted or modified by the user. Also clarify the behaviour of another existing test. * Move around some code to make the main target promotion logic more visible. Signed-off-by: Andrey Mokhov --- src/dune_engine/build_system.ml | 2 +- src/dune_engine/target_promotion.ml | 153 +++++++++--------- src/dune_engine/target_promotion.mli | 2 +- .../test-cases/promote/old-tests.t/run.t | 21 +++ 4 files changed, 97 insertions(+), 81 deletions(-) diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 55076cf9a27d..5ad002b644fa 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -1911,7 +1911,7 @@ end = struct | Promote _, Some Never -> Fiber.return () | Promote promote, (Some Automatically | None) -> - Target_promotion.promote ~dir ~targets ~promote + Target_promotion.promote ~dir ~targets_and_digests ~promote ~promote_source:(fun ~chmod -> t.promote_source ~chmod context) in t.rule_done <- t.rule_done + 1; diff --git a/src/dune_engine/target_promotion.ml b/src/dune_engine/target_promotion.ml index 0c76db981879..0975bc9da7ac 100644 --- a/src/dune_engine/target_promotion.ml +++ b/src/dune_engine/target_promotion.ml @@ -103,91 +103,86 @@ let delete_stale_dot_merlin_file ~dir ~source_files_to_ignore = in source_files_to_ignore -let promote ~dir ~targets ~promote ~promote_source = - let open Fiber.O in - let { Rule.Promote.lifetime; only; into; _ } = promote in - (* CR-someday amokhov: Don't ignore directory targets. *) - let file_targets = - Targets.map targets ~f:(fun ~files ~dirs -> - ignore dirs; - files) +let promote ~dir ~targets_and_digests ~promote ~promote_source = + let selected_for_promotion = + match promote.Rule.Promote.only with + | None -> fun (_ : Path.Build.t) -> true + | Some pred -> + fun target -> + Predicate_lang.Glob.exec pred ~standard:Predicate_lang.any + (Path.reach ~from:(Path.build dir) (Path.build target)) + in + let relocate = + match promote.into with + | None -> Fun.id + | Some { loc; dir } -> + fun target_in_source_tree -> + Path.Source.relative + (Path.Source.relative + (Path.Source.parent_exn target_in_source_tree) + dir ~error_loc:loc) + (Path.Source.basename target_in_source_tree) in - Fiber.parallel_iter_set - (module Path.Build.Set) - file_targets - ~f:(fun target -> - let consider_for_promotion = - match only with - | None -> true - | Some pred -> - Predicate_lang.Glob.exec pred - (Path.reach (Path.build target) ~from:(Path.build dir)) - ~standard:Predicate_lang.any + let open Fiber.O in + (* CR-someday amokhov: When promoting directory targets, we might want to + create the destination directory instead of reporting an error. Maybe we + should just always do that? After all, if the user says "promote results + into this directory, please", they might expect Dune to create it too. *) + let ensure_the_destination_directory_exists ~dst = + let dir = Path.Source.parent_exn dst in + Memo.Build.run (Source_tree.find_dir dir) >>| function + | Some (_ : Source_tree.Dir.t) -> () + | None -> + let loc = + match promote.into with + | Some into -> into.loc + | None -> + (* CR-someday amokhov: It's not entirely clear why this is a code + error. If the user deletes the source directory (along with the + corresponding [dune] file), we are going to hit this branch, and + presumably this isn't Dune's fault. *) + Code_error.raise + "Promoting into a directory that does not exist. Perhaps, the user \ + deleted it while Dune was running?" + [ ("dst", Path.Source.to_dyn dst) ] in - match consider_for_promotion with + User_error.raise ~loc + [ Pp.textf "directory %S does not exist" + (Path.Source.to_string_maybe_quoted dir) + ] + in + (* CR-someday amokhov: Here we use a tracked operation to compute the digest + of the destination file. However, later we may replace the destination with + a new content, hence triggering a rebuild. To avoid that, right now we are + using [Scheduler.ignore_for_watch], whose implementation is pretty hacky. A + better solution would be to temporarily disable file-tracking here and only + re-enable it after the promotion is complete. *) + let destination_is_up_to_date ~target_digest ~dst = + let open Memo.Build.O in + Memo.Build.run + (Fs_memo.path_digest dst >>| Cached_digest.Digest_result.to_option + >>| function + | None -> false + | Some dst_digest -> Digest.equal target_digest dst_digest) + in + Fiber.parallel_iter targets_and_digests ~f:(fun (target, target_digest) -> + match selected_for_promotion target with | false -> Fiber.return () - | true -> - let in_source_tree = Path.Build.drop_build_context_exn target in - let in_source_tree = - match into with - | None -> in_source_tree - | Some { loc; dir } -> - Path.Source.relative - (Path.Source.relative - (Path.Source.parent_exn in_source_tree) - dir ~error_loc:loc) - (Path.Source.basename in_source_tree) - in - let* () = - let dir = Path.Source.parent_exn in_source_tree in - Memo.Build.run (Source_tree.find_dir dir) >>| function - | Some _ -> () - | None -> - let loc = - match into with - | Some into -> into.loc - | None -> - Code_error.raise "promoting into directory that does not exist" - [ ("in_source_tree", Path.Source.to_dyn in_source_tree) ] - in - User_error.raise ~loc - [ Pp.textf "directory %S does not exist" - (Path.Source.to_string_maybe_quoted dir) - ] - in - let dst = in_source_tree in - let in_source_tree = Path.source in_source_tree in - let* is_up_to_date = - Memo.Build.run - (let open Memo.Build.O in - Fs_memo.path_digest in_source_tree - >>| Cached_digest.Digest_result.to_option - >>| function - | None -> false - | Some in_source_tree_digest -> ( - match - Cached_digest.build_file target - |> Cached_digest.Digest_result.to_option - with - | None -> - (* CR-someday amokhov: We couldn't digest the target so - something happened to it. Right now, we skip the promotion in - this case, but we could perhaps delete the corresponding path - in the source tree. *) - true - | Some in_build_dir_digest -> - Digest.equal in_build_dir_digest in_source_tree_digest)) - in - if is_up_to_date then - Fiber.return () - else ( - if lifetime = Until_clean then To_delete.add dst; - let* () = Scheduler.ignore_for_watch in_source_tree in + | true -> ( + let dst = relocate (Path.Build.drop_build_context_exn target) in + let* () = ensure_the_destination_directory_exists ~dst in + let dst_path = Path.source dst in + destination_is_up_to_date ~target_digest ~dst:dst_path >>= function + | true -> Fiber.return () + | false -> + (match promote.lifetime with + | Until_clean -> To_delete.add dst + | Unlimited -> ()); + let* () = Scheduler.ignore_for_watch dst_path in (* The file in the build directory might be read-only if it comes from the shared cache. However, we want the file in the source tree to be writable by the user, so we explicitly set the user writable bit. *) let chmod n = n lor 0o200 in Path.Source.unlink_no_err dst; - promote_source ~chmod ~src:target ~dst - )) + promote_source ~chmod ~src:target ~dst)) diff --git a/src/dune_engine/target_promotion.mli b/src/dune_engine/target_promotion.mli index 48245de7ff75..9cb4483357e4 100644 --- a/src/dune_engine/target_promotion.mli +++ b/src/dune_engine/target_promotion.mli @@ -4,7 +4,7 @@ open! Stdune val promote : dir:Path.Build.t - -> targets:Targets.t + -> targets_and_digests:(Path.Build.t * Digest.t) list -> promote:Rule.Promote.t -> promote_source: ( chmod:(int -> int) diff --git a/test/blackbox-tests/test-cases/promote/old-tests.t/run.t b/test/blackbox-tests/test-cases/promote/old-tests.t/run.t index 366ebbbd60f0..43d6310e533c 100644 --- a/test/blackbox-tests/test-cases/promote/old-tests.t/run.t +++ b/test/blackbox-tests/test-cases/promote/old-tests.t/run.t @@ -108,12 +108,33 @@ Only "only1" should be promoted in the source tree: $ ls -1 only* only1 +Test that Dune restores only1 if it's deleted from the source tree + + $ rm only1 + $ dune build only2 + $ ls -1 only* + only1 + +Test that Dune restores only1 if it's modified in the source tree + + $ cat only1 + 0 + $ echo 1 > only1 + $ dune build only2 + $ cat only1 + 0 + Test for (promote (into ...)) + (enabled_if %{ignoring_promoted_rules} ---------------------------------------------------------------------- $ dune build into+ignoring + $ ls -1 subdir/into* + subdir/into+ignoring + $ dune clean $ dune build into+ignoring --ignore-promoted-rules + $ ls -1 _build/default/into* + _build/default/into+ignoring Reproduction case for #3069 --------------------------- From 6cd70bbcb4d462cb847483fe95eff68a9404fe98 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Mon, 1 Nov 2021 17:51:47 +0000 Subject: [PATCH 11/32] Rename [promotion.ml] to [diff_promotion.ml] (#5071) This is just to avoid confusion. The term "promotion" can mean two related but slightly different things ([diff] promotion and target promotion for rules using [mode promote]), so it helps to be specific about which promotion is meant. After this PR, we have two modules responsive for each kind of promotion: [Diff_promotion] and [Target_promotion]. Signed-off-by: Andrey Mokhov --- bin/import.ml | 2 +- bin/promote.ml | 2 +- src/dune_engine/action_exec.ml | 11 ++++++----- src/dune_engine/build_system.ml | 6 ++++-- src/dune_engine/build_system.mli | 2 +- src/dune_engine/{promotion.ml => diff_promotion.ml} | 0 src/dune_engine/{promotion.mli => diff_promotion.mli} | 0 src/dune_engine/dune_engine.ml | 2 +- src/dune_engine/target_promotion.mli | 4 +++- src/dune_rpc_impl/diagnostics.ml | 1 - src/dune_rpc_impl/server.ml | 5 +++-- 11 files changed, 20 insertions(+), 15 deletions(-) rename src/dune_engine/{promotion.ml => diff_promotion.ml} (100%) rename src/dune_engine/{promotion.mli => diff_promotion.mli} (100%) diff --git a/bin/import.ml b/bin/import.ml index 477fef5e44b5..4f7f9b7143d4 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -20,7 +20,7 @@ module Dpath = Dune_engine.Dpath module Install = Dune_engine.Install module Section = Dune_engine.Section module Watermarks = Dune_rules.Watermarks -module Promotion = Dune_engine.Promotion +module Diff_promotion = Dune_engine.Diff_promotion module Colors = Dune_rules.Colors module Dune_project = Dune_engine.Dune_project module Workspace = Dune_rules.Workspace diff --git a/bin/promote.ml b/bin/promote.ml index 98736b7a6704..792bc0dbea7e 100644 --- a/bin/promote.ml +++ b/bin/promote.ml @@ -23,7 +23,7 @@ let command = Arg.(value & pos_all Cmdliner.Arg.file [] & info [] ~docv:"FILE") in let _config = Common.init common in - Promotion.promote_files_registered_in_last_run + Diff_promotion.promote_files_registered_in_last_run (match files with | [] -> All | _ -> diff --git a/src/dune_engine/action_exec.ml b/src/dune_engine/action_exec.ml index 32c27eeb1210..ea1d9f66e671 100644 --- a/src/dune_engine/action_exec.ml +++ b/src/dune_engine/action_exec.ml @@ -305,11 +305,11 @@ let rec exec t ~ectx ~eenv = Fiber.finalize (fun () -> let annot = - Promotion.Annot.make - { Promotion.Annot.in_source = source_file + Diff_promotion.Annot.make + { Diff_promotion.Annot.in_source = source_file ; in_build = (if optional && in_source_or_target then - Promotion.File.in_staging_area source_file + Diff_promotion.File.in_staging_area source_file else file2) } @@ -332,10 +332,11 @@ let rec exec t ~ectx ~eenv = in_source_or_target && not (is_copied_from_source_tree (Path.build file2)) then - Promotion.File.register_dep ~source_file ~correction_file:file2 + Diff_promotion.File.register_dep ~source_file + ~correction_file:file2 | true -> if in_source_or_target then - Promotion.File.register_intermediate ~source_file + Diff_promotion.File.register_intermediate ~source_file ~correction_file:file2 else remove_intermediate_file ()); diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 5ad002b644fa..b47dca18056c 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -243,7 +243,9 @@ module Error = struct (fun () -> None) let extract_promote annot = - Promotion.Annot.check annot (fun promote -> Some promote) (fun () -> None) + Diff_promotion.Annot.check annot + (fun promote -> Some promote) + (fun () -> None) let promotion t = let e = @@ -2361,7 +2363,7 @@ let handle_final_exns exns = let run f = let open Fiber.O in - Hooks.End_of_build.once Promotion.finalize; + Hooks.End_of_build.once Diff_promotion.finalize; let t = t () in let old_errors = t.errors in t.errors <- []; diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli index 292ce4268ef6..7033ae317583 100644 --- a/src/dune_engine/build_system.mli +++ b/src/dune_engine/build_system.mli @@ -26,7 +26,7 @@ module Error : sig val info : t -> User_message.t * User_message.t list * Path.t option - val promotion : t -> Promotion.Annot.t option + val promotion : t -> Diff_promotion.Annot.t option val id : t -> Id.t end diff --git a/src/dune_engine/promotion.ml b/src/dune_engine/diff_promotion.ml similarity index 100% rename from src/dune_engine/promotion.ml rename to src/dune_engine/diff_promotion.ml diff --git a/src/dune_engine/promotion.mli b/src/dune_engine/diff_promotion.mli similarity index 100% rename from src/dune_engine/promotion.mli rename to src/dune_engine/diff_promotion.mli diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index ff7bf4e5ded0..2e68becbb2b1 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -51,7 +51,7 @@ module Action_to_sh = Action_to_sh module Diff = Diff module Scheduler = Scheduler module Hooks = Hooks -module Promotion = Promotion +module Diff_promotion = Diff_promotion module Cached_digest = Cached_digest module Pform = Pform module Cm_kind = Cm_kind diff --git a/src/dune_engine/target_promotion.mli b/src/dune_engine/target_promotion.mli index 9cb4483357e4..f1ff19263173 100644 --- a/src/dune_engine/target_promotion.mli +++ b/src/dune_engine/target_promotion.mli @@ -1,4 +1,6 @@ -(** Promoting rule targets to the source tree. *) +(** Promoting rule targets to the source tree. + + See [Diff_promotion] for the logic related to promoting [diff]s. *) open! Stdune diff --git a/src/dune_rpc_impl/diagnostics.ml b/src/dune_rpc_impl/diagnostics.ml index c128311082e2..dccd86f9b323 100644 --- a/src/dune_rpc_impl/diagnostics.ml +++ b/src/dune_rpc_impl/diagnostics.ml @@ -12,7 +12,6 @@ module Dep_conf = Dune_rules.Dep_conf module Source_tree = Dune_engine.Source_tree module Build_system = Dune_engine.Build_system module Dune_project = Dune_engine.Dune_project -module Promotion = Dune_engine.Promotion let absolutize_paths ~dir (loc : Loc.t) = let make_path name = diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index bea275736310..9ccd16c32878 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -16,7 +16,7 @@ module Dep_conf = Dune_rules.Dep_conf module Source_tree = Dune_engine.Source_tree module Build_system = Dune_engine.Build_system module Dune_project = Dune_engine.Dune_project -module Promotion = Dune_engine.Promotion +module Diff_promotion = Dune_engine.Diff_promotion module Build_outcome = Decl.Build_outcome module Status = Decl.Status @@ -275,7 +275,8 @@ let handler (t : t Fdecl.t) : 'a Dune_rpc_server.Handler.t = let () = let f _ path = let files = source_path_of_string path in - Promotion.promote_files_registered_in_last_run (These ([ files ], ignore)); + Diff_promotion.promote_files_registered_in_last_run + (These ([ files ], ignore)); Fiber.return () in Handler.implement_request rpc Procedures.Public.promote f From 05c1fa87cecbc7229e787805df1c813fb6fbe015 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 29 Oct 2021 16:59:36 -0600 Subject: [PATCH 12/32] test: rename directory targets tests allows to include additional tests in the same directory. Signed-off-by: Rudi Grinberg ps-id: 4C1A83EC-DECF-4479-9F52-88942309865C --- .../{directory-targets.t/run.t => directory-targets/main.t} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename test/blackbox-tests/test-cases/{directory-targets.t/run.t => directory-targets/main.t} (100%) diff --git a/test/blackbox-tests/test-cases/directory-targets.t/run.t b/test/blackbox-tests/test-cases/directory-targets/main.t similarity index 100% rename from test/blackbox-tests/test-cases/directory-targets.t/run.t rename to test/blackbox-tests/test-cases/directory-targets/main.t From b8b413a86591f453af76e3275a28f0d719e8de72 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 31 Oct 2021 23:59:26 -0600 Subject: [PATCH 13/32] test: add test for depending on dir Signed-off-by: Rudi Grinberg --- .../directory-targets/source-dir-dep.t | 28 +++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 test/blackbox-tests/test-cases/directory-targets/source-dir-dep.t diff --git a/test/blackbox-tests/test-cases/directory-targets/source-dir-dep.t b/test/blackbox-tests/test-cases/directory-targets/source-dir-dep.t new file mode 100644 index 000000000000..dee8a81eda38 --- /dev/null +++ b/test/blackbox-tests/test-cases/directory-targets/source-dir-dep.t @@ -0,0 +1,28 @@ +Depend on a source directory. + +Currently, this feature isn't working. It's only possible to depend on +directories that are a target of a rule. + + $ cat >dune-project < (lang dune 3.0) + > (using directory-targets 0.1) + > EOF + + $ mkdir foo + $ touch foo/{x,y,z} + + $ cat >dune < (rule + > (deps foo) + > (target bar) + > (action (bash "ls -f %{deps} > %{target}"))) + > EOF + + $ dune build ./bar + File "dune", line 1, characters 0-77: + 1 | (rule + 2 | (deps foo) + 3 | (target bar) + 4 | (action (bash "ls -f %{deps} > %{target}"))) + Error: No rule found for foo + [1] From e1780c2e392113a2e29147688a8a76ce3355cd3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 2 Nov 2021 12:10:05 +0000 Subject: [PATCH 14/32] Add a test documenting Dune's display modes (#5073) Signed-off-by: Jeremie Dimino --- test/blackbox-tests/test-cases/display.t | 153 +++++++++++++++++++++++ 1 file changed, 153 insertions(+) create mode 100644 test/blackbox-tests/test-cases/display.t diff --git a/test/blackbox-tests/test-cases/display.t b/test/blackbox-tests/test-cases/display.t new file mode 100644 index 000000000000..a5c41d1a57fb --- /dev/null +++ b/test/blackbox-tests/test-cases/display.t @@ -0,0 +1,153 @@ +Document how Dune displays various things +========================================= + + $ echo '(lang dune 3.0)' > dune-project + $ export BUILD_PATH_PREFIX_MAP=SH=`command -v sh` + +Errors with location embed in their output +------------------------------------------ + + $ cat >dune<<"EOF" + > (rule + > (alias default) + > (action (system "echo 'File \"foo\", line 1: blah'; exit 42"))) + > EOF + + $ dune clean; dune build + File "foo", line 1: blah + [1] + + $ dune clean; dune build --always-show-command-line + sh alias default (exit 42) + (cd _build/default && SH -c 'echo '\''File "foo", line 1: blah'\''; exit 42') + File "foo", line 1: blah + [1] + + $ dune clean; dune build --display short + File "foo", line 1: blah + [1] + + $ dune clean; dune build --display short --always-show-command-line + sh alias default (exit 42) + (cd _build/default && SH -c 'echo '\''File "foo", line 1: blah'\''; exit 42') + File "foo", line 1: blah + [1] + +Errors without location embed in their output +--------------------------------------------- + + $ cat >dune<<"EOF" + > (rule + > (alias default) + > (action (system "echo failure; exit 42"))) + > EOF + + $ dune clean; dune build + File "dune", line 1, characters 0-66: + 1 | (rule + 2 | (alias default) + 3 | (action (system "echo failure; exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'echo failure; exit 42') + failure + [1] + + $ dune clean; dune build --always-show-command-line + File "dune", line 1, characters 0-66: + 1 | (rule + 2 | (alias default) + 3 | (action (system "echo failure; exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'echo failure; exit 42') + failure + [1] + + $ dune clean; dune build --display short + File "dune", line 1, characters 0-66: + 1 | (rule + 2 | (alias default) + 3 | (action (system "echo failure; exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'echo failure; exit 42') + failure + [1] + + $ dune clean; dune build --display short --always-show-command-line + File "dune", line 1, characters 0-66: + 1 | (rule + 2 | (alias default) + 3 | (action (system "echo failure; exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'echo failure; exit 42') + failure + [1] + +Errors with no output +--------------------- + + $ cat >dune<<"EOF" + > (rule + > (alias default) + > (action (system "exit 42"))) + > EOF + + $ dune clean; dune build + File "dune", line 1, characters 0-52: + 1 | (rule + 2 | (alias default) + 3 | (action (system "exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'exit 42') + [1] + + $ dune clean; dune build --always-show-command-line + File "dune", line 1, characters 0-52: + 1 | (rule + 2 | (alias default) + 3 | (action (system "exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'exit 42') + [1] + + $ dune clean; dune build --display short + File "dune", line 1, characters 0-52: + 1 | (rule + 2 | (alias default) + 3 | (action (system "exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'exit 42') + [1] + + $ dune clean; dune build --display short --always-show-command-line + File "dune", line 1, characters 0-52: + 1 | (rule + 2 | (alias default) + 3 | (action (system "exit 42"))) + sh alias default (exit 42) + (cd _build/default && SH -c 'exit 42') + [1] + +Successful commands with output +------------------------------- + + $ cat >dune<<"EOF" + > (rule + > (alias default) + > (action (system "echo 'Hello, world!'"))) + > EOF + + $ dune clean; dune build + sh alias default + Hello, world! + + $ dune clean; dune build --always-show-command-line + sh alias default + Hello, world! + + $ dune clean; dune build --display short + sh alias default + Hello, world! + + $ dune clean; dune build --display short --always-show-command-line + sh alias default + Hello, world! From bc073c86f36954010d866215ed5fe69db70de393 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 2 Nov 2021 12:49:27 +0000 Subject: [PATCH 15/32] Add a rule mode to "patch back the source tree" (#5020) Necessary evil to port complicated rules from project not using Dune that try to modify/create random files in the source tree. Signed-off-by: Jeremie Dimino --- otherlibs/stdune-unstable/map.ml | 7 + otherlibs/stdune-unstable/map_intf.ml | 2 + src/dune_engine/build_system.ml | 58 +++++- src/dune_engine/cached_digest.ml | 2 - src/dune_engine/cached_digest.mli | 12 ++ src/dune_engine/import.ml | 4 + src/dune_engine/rule.ml | 14 ++ src/dune_engine/rule.mli | 15 ++ src/dune_engine/rules.ml | 3 +- src/dune_engine/rules.mli | 10 +- src/dune_engine/sandbox.ml | 103 +++++++++- src/dune_engine/sandbox.mli | 2 + src/dune_engine/sandbox_mode.ml | 6 +- src/dune_engine/sandbox_mode.mli | 2 + src/dune_rules/dune_file.ml | 14 ++ src/dune_rules/simple_rules.ml | 11 +- src/dune_rules/simple_rules.mli | 1 + src/dune_rules/super_context.ml | 5 +- src/dune_rules/super_context.mli | 1 + test/blackbox-tests/test-cases/dune | 5 + .../test-cases/patch-back-source-tree.t | 186 ++++++++++++++++++ 21 files changed, 433 insertions(+), 30 deletions(-) create mode 100644 test/blackbox-tests/test-cases/patch-back-source-tree.t diff --git a/otherlibs/stdune-unstable/map.ml b/otherlibs/stdune-unstable/map.ml index 65f0221c52b2..71a4de3e82a2 100644 --- a/otherlibs/stdune-unstable/map.ml +++ b/otherlibs/stdune-unstable/map.ml @@ -55,6 +55,13 @@ module Make (Key : Key) : S with type key = Key.t = struct let iter t ~f = iteri t ~f:(fun _ x -> f x) + let iter2 a b ~f = + ignore + (merge a b ~f:(fun key a b -> + f key a b; + None) + : _ t) + let foldi t ~init ~f = fold t ~init ~f:(fun ~key ~data acc -> f key data acc) let fold t ~init ~f = foldi t ~init ~f:(fun _ x acc -> f x acc) diff --git a/otherlibs/stdune-unstable/map_intf.ml b/otherlibs/stdune-unstable/map_intf.ml index d0c5353dbaae..72dd2ec6f7d1 100644 --- a/otherlibs/stdune-unstable/map_intf.ml +++ b/otherlibs/stdune-unstable/map_intf.ml @@ -45,6 +45,8 @@ module type S = sig val iteri : 'a t -> f:(key -> 'a -> unit) -> unit + val iter2 : 'a t -> 'b t -> f:(key -> 'a option -> 'b option -> unit) -> unit + val fold : 'a t -> init:'b -> f:('a -> 'b -> 'b) -> 'b val foldi : 'a t -> init:'b -> f:(key -> 'a -> 'b -> 'b) -> 'b diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index b47dca18056c..6f1b8427a465 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -369,7 +369,7 @@ let get_dir_triage t ~dir = Memo.Build.return @@ Dir_triage.Known (Non_build - (match Path.readdir_unsorted dir with + (match Path.Untracked.readdir_unsorted dir with | Error (Unix.ENOENT, _, _) -> Path.Set.empty | Error (e, _syscall, _arg) -> (* CR-someday amokhov: Print [_syscall] and [_arg] too to help @@ -839,7 +839,8 @@ end = struct match rule.mode with | Standard | Promote _ - | Ignore_source_files -> + | Ignore_source_files + | Patch_back_source_tree -> true | Fallback -> let source_files_for_targets = @@ -1000,7 +1001,8 @@ end = struct in Path.Build.Set.union to_ignore acc_ignored | Standard - | Fallback -> + | Fallback + | Patch_back_source_tree -> acc_ignored) in let source_files_to_ignore = @@ -1454,7 +1456,7 @@ end = struct let execute_action_for_rule t ~rule_digest ~action ~deps ~loc ~(context : Build_context.t option) ~execution_parameters ~sandbox_mode - ~dir ~targets = + ~dir ~targets ~(rule_mode : Rule.Mode.t) = let open Fiber.O in let file_targets, has_directory_targets = Targets.map targets ~f:(fun ~files ~dirs -> @@ -1467,7 +1469,12 @@ end = struct let chdirs = Action.chdirs action in let sandbox = Option.map sandbox_mode ~f:(fun mode -> - Sandbox.create ~mode ~deps ~rule_dir:dir ~chdirs ~rule_digest + Sandbox.create ~mode ~deps + ~patch_back_source_tree: + (match rule_mode with + | Patch_back_source_tree -> true + | _ -> false) + ~rule_dir:dir ~rule_loc:loc ~chdirs ~rule_digest ~expand_aliases: (Execution_parameters.expand_aliases_in_sandbox execution_parameters)) @@ -1651,6 +1658,13 @@ end = struct not expected to change often, so we do not sacrifice too much performance here by executing it sequentially. *) let* action, deps = Action_builder.run action Eager in + let action = + (* Rules that patch back the source tree cannot go in the shared cache *) + match (mode, action.can_go_in_shared_cache) with + | Patch_back_source_tree, true -> + { action with can_go_in_shared_cache = false } + | _ -> action + in let wrap_fiber f = Memo.Build.of_reproducible_fiber (if Loc.is_none loc then @@ -1857,6 +1871,7 @@ end = struct let* exec_result = execute_action_for_rule t ~rule_digest ~action ~deps ~loc ~context ~execution_parameters ~sandbox_mode ~dir ~targets + ~rule_mode:mode in let* targets_and_digests = (* Step IV. Store results to the shared cache and if that step @@ -1909,7 +1924,9 @@ end = struct in let* () = match (mode, !Clflags.promote) with - | (Standard | Fallback | Ignore_source_files), _ + | ( ( Standard | Fallback | Ignore_source_files + | Patch_back_source_tree ) + , _ ) | Promote _, Some Never -> Fiber.return () | Promote promote, (Some Automatically | None) -> @@ -1974,8 +1991,13 @@ end = struct } in let rule = - let { Rule.Anonymous_action.context; action = _; loc; dir = _; alias = _ } - = + let { Rule.Anonymous_action.context + ; action = _ + ; loc + ; dir = _ + ; alias = _ + ; patch_back_source_tree + } = act in Rule.make ~context @@ -1984,6 +2006,11 @@ end = struct | Some loc -> From_dune_file loc | None -> Internal) ~targets:(Targets.File.create target) + ~mode: + (if patch_back_source_tree then + Patch_back_source_tree + else + Standard) (Action_builder.of_thunk { f = (fun mode -> @@ -2005,7 +2032,8 @@ end = struct ~input:(module Anonymous_action) execute_action_generic_stage2_impl - let execute_action_generic ~observing_facts act ~capture_stdout = + let execute_action_generic ~observing_facts (act : Rule.Anonymous_action.t) + ~capture_stdout = (* We memoize the execution of anonymous actions, both via the persistent mechanism for not re-running build rules between invocations of [dune build] and via [Memo]. The former is done by producing a normal build @@ -2031,12 +2059,21 @@ end = struct (* Shadow [observing_facts] to make sure we don't use it again. *) let observing_facts = () in ignore observing_facts; + let act = + (* Actions that patch back the source tree cannot go in the shared + cache *) + if act.patch_back_source_tree && act.action.can_go_in_shared_cache then + { act with action = { act.action with can_go_in_shared_cache = false } } + else + act + in let digest = let { Rule.Anonymous_action.context ; action = { action; env; locks; can_go_in_shared_cache } ; loc ; dir ; alias + ; patch_back_source_tree } = act in @@ -2068,7 +2105,8 @@ end = struct , dir , alias , capture_stdout - , can_go_in_shared_cache ) + , can_go_in_shared_cache + , patch_back_source_tree ) in (* It might seem superfluous to memoize the execution here, given that a given anonymous action will typically only appear once during a given diff --git a/src/dune_engine/cached_digest.ml b/src/dune_engine/cached_digest.ml index 7a1201331871..9eee080eb78e 100644 --- a/src/dune_engine/cached_digest.ml +++ b/src/dune_engine/cached_digest.ml @@ -1,7 +1,5 @@ open Import -(* The reduced set of file stats this module inspects to decide whether a file - changed or not *) module Reduced_stats = struct type t = { mtime : float diff --git a/src/dune_engine/cached_digest.mli b/src/dune_engine/cached_digest.mli index 091853ead7cb..9da19ed2c225 100644 --- a/src/dune_engine/cached_digest.mli +++ b/src/dune_engine/cached_digest.mli @@ -45,3 +45,15 @@ val remove : Path.Build.t -> unit (** Invalidate all cached [stat] values. This causes all subsequent calls to [build_file] or [source_or_external_file] to incur additional [stat] calls. *) val invalidate_cached_timestamps : unit -> unit + +(** The reduced set of file stats this module inspects to decide whether a file + changed or not *) +module Reduced_stats : sig + type t + + val to_dyn : t -> Dyn.t + + val of_unix_stats : Unix.stats -> t + + val compare : t -> t -> Ordering.t +end diff --git a/src/dune_engine/import.ml b/src/dune_engine/import.ml index e00a83a3b550..09842eb9b77d 100644 --- a/src/dune_engine/import.ml +++ b/src/dune_engine/import.ml @@ -15,6 +15,8 @@ module Path = struct module Untracked = struct let exists = exists + let readdir_unsorted = readdir_unsorted + let readdir_unsorted_with_kinds = readdir_unsorted_with_kinds let stat = stat @@ -39,6 +41,8 @@ module Path = struct let lstat_exn = `Use_fs_memo_lstat_instead + let readdir_unsorted = `Use_fs_memo_dir_contents_instead + let readdir_unsorted_with_kinds = `Use_fs_memo_dir_contents_instead end diff --git a/src/dune_engine/rule.ml b/src/dune_engine/rule.ml index c54af4f023f3..803296135f4f 100644 --- a/src/dune_engine/rule.ml +++ b/src/dune_engine/rule.ml @@ -46,6 +46,7 @@ module Mode = struct | Fallback | Promote of Promote.t | Ignore_source_files + | Patch_back_source_tree end module Id = Id.Make () @@ -90,6 +91,18 @@ let add_sandbox_config : let make ?(sandbox = Sandbox_config.default) ?(mode = Mode.Standard) ~context ?(info = Info.Internal) ~targets action = + let sandbox = + match mode with + | Patch_back_source_tree -> + (* If the user specifies (sandbox none), then we get a slightly confusing + error message. We could detect this case at parsing time and produce a + better error message. It's a bit awkard to implement this check at the + moment as the sandbox config is specified in the dependencies, but we + plan to change that in the future. *) + Sandbox_config.inter sandbox + (Sandbox_mode.Set.singleton Sandbox_mode.copy) + | _ -> sandbox + in let action = let open Memo.Build.O in Action_builder.memoize "Rule.make" @@ -149,5 +162,6 @@ module Anonymous_action = struct ; loc : Loc.t option ; dir : Path.Build.t ; alias : Alias.Name.t option + ; patch_back_source_tree : bool } end diff --git a/src/dune_engine/rule.mli b/src/dune_engine/rule.mli index bc69cfbdbb80..89378e352b7c 100644 --- a/src/dune_engine/rule.mli +++ b/src/dune_engine/rule.mli @@ -45,6 +45,20 @@ module Mode : sig (** Just ignore the source files entirely. This is for cases where the targets are promoted only in a specific context, such as for .install files. *) + | Patch_back_source_tree + (** Apply all the changes that happend in the sandbox to the source + tree. This includes: + + - applying changes to source files that were dependencies + - deleting source files that were dependencies and were deleted in + the sandbox + - promoting all targets + - promoting all files that were created and not declared as + dependencies or targets + + This is a dirty setting, but it is necessary to port projects to + Dune that don't use a separate directory and have rules that go and + create/modify random files. *) end module Id : sig @@ -107,5 +121,6 @@ module Anonymous_action : sig (** Directory the action is attached to. This is the directory where the outcome of the action will be cached. *) ; alias : Alias.Name.t option (** For better error messages *) + ; patch_back_source_tree : bool } end diff --git a/src/dune_engine/rules.ml b/src/dune_engine/rules.ml index f9ff7a5e497f..758607f43df6 100644 --- a/src/dune_engine/rules.ml +++ b/src/dune_engine/rules.ml @@ -148,7 +148,7 @@ module Produce = struct Appendable_list.singleton (loc, Dir_rules.Alias_spec.Deps expansion) } - let add_action t ~context ~loc action = + let add_action t ~context ~loc ~patch_back_source_tree action = let action = let open Action_builder.O in let+ action = action in @@ -157,6 +157,7 @@ module Produce = struct ; loc ; dir = Alias.dir t ; alias = Some (Alias.name t) + ; patch_back_source_tree } in alias t diff --git a/src/dune_engine/rules.mli b/src/dune_engine/rules.mli index f60c01a623e3..85c7e09c615d 100644 --- a/src/dune_engine/rules.mli +++ b/src/dune_engine/rules.mli @@ -73,19 +73,21 @@ module Produce : sig module Alias : sig type t = Alias.t - (** [add_deps store alias deps] arrange things so that all the dependencies + (** [add_deps alias ?loc deps] arrange things so that all the dependencies registered by [deps] are considered as a part of alias expansion of [alias]. *) val add_deps : t -> ?loc:Stdune.Loc.t -> unit Action_builder.t -> unit Memo.Build.t - (** [add_action store alias ~stamp action] arrange things so that [action] - is executed as part of the build of alias [alias]. [stamp] is any - S-expression that is unique and persistent S-expression. *) + (** [add_action alias ~context ~loc ?patch_back_source_tree + 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 option + -> patch_back_source_tree:bool -> Action.Full.t Action_builder.t -> unit Memo.Build.t end diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index a5255e8d90a7..4673d6f6b250 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -21,7 +21,15 @@ let init = in fun () -> Lazy.force init -type t = { dir : Path.Build.t } [@@unboxed] +(* Snapshot used to detect modifications. We use the same algorithm as + [Cached_digest] given that we are trying to detect the same kind of + changes. *) +type snapshot = Cached_digest.Reduced_stats.t Path.Map.t + +type t = + { dir : Path.Build.t + ; snapshot : snapshot option + } let dir t = t.dir @@ -69,8 +77,18 @@ let link_function ~(mode : Sandbox_mode.some) = | true -> win32_error mode | false -> fun src dst -> Io.portable_hardlink ~src ~dst)) -let link_deps t ~mode ~deps = - let link = Staged.unstage (link_function ~mode) in +let copy_and_make_writable src dst = + Io.copy_file ~src ~dst ~chmod:(fun n -> n lor 0o200) () + +let link_deps t ~mode ~patch_back_source_tree ~deps = + let link = + if patch_back_source_tree then + (* We need to let the action modify its dependencies, so we copy + dependencies and make them writable. *) + copy_and_make_writable + else + Staged.unstage (link_function ~mode) + in Path.Map.iteri deps ~f:(fun path (_ : Digest.t) -> match Path.as_in_build_dir path with | None -> @@ -83,11 +101,31 @@ let link_deps t ~mode ~deps = [ ("path", Path.to_dyn path) ] | Some p -> link path (Path.build (map_path t p))) -let create ~mode ~deps ~rule_dir ~chdirs ~rule_digest ~expand_aliases = +let snapshot t = + (* CR-someday jeremiedimino: we do this kind of traversal in other places. + Might be worth trying to factorise the code. *) + let rec walk dir acc = + match Path.Untracked.readdir_unsorted dir with + | Error (err, func, arg) -> raise (Unix.Unix_error (err, func, arg)) + | Ok files -> + List.fold_left files ~init:acc ~f:(fun acc basename -> + let p = Path.relative dir basename in + let stats = Path.Untracked.lstat_exn p in + match stats.st_kind with + | S_REG -> + Path.Map.add_exn acc p + (Cached_digest.Reduced_stats.of_unix_stats stats) + | S_DIR -> walk p acc + | _ -> acc) + in + walk (Path.build t.dir) Path.Map.empty + +let create ~mode ~patch_back_source_tree ~rule_loc ~deps ~rule_dir ~chdirs + ~rule_digest ~expand_aliases = init (); let sandbox_suffix = rule_digest |> Digest.to_string in let sandbox_dir = Path.Build.relative sandbox_dir sandbox_suffix in - let t = { dir = sandbox_dir } in + let t = { dir = sandbox_dir; snapshot = None } in Path.rm_rf (Path.build sandbox_dir); create_dirs t ~deps ~chdirs ~rule_dir; let deps = @@ -98,8 +136,27 @@ let create ~mode ~deps ~rule_dir ~chdirs ~rule_digest ~expand_aliases = in (* CR-someday amokhov: Note that this doesn't link dynamic dependencies, so targets produced dynamically will be unavailable. *) - link_deps t ~mode ~deps; - t + link_deps t ~mode ~patch_back_source_tree ~deps; + if patch_back_source_tree then ( + (* Only supported on Linux because we rely on the mtime changing to detect + when a file changes. This doesn't work on OSX for instance as the file + system granularity is 1s, which is too coarse. *) + if not Sys.linux then + User_error.raise ~loc:rule_loc + [ Pp.textf + "(mode patch-back-source-tree) is only supported on Linux at the \ + moment." + ]; + (* We expect this call to [snapshot t] to return the same set of files as + [deps], given that's exactly what we just copied in the sandbox. So in + theory, we could iterate over [deps] rather than scan the file system. + However, the code is simpler if we just call [snapshot t] before and + after running the action. Given that [patch_back_source_tree] is a dodgy + feature that we hope to get rid of in the long run, we favor code + simplicity over performance. *) + { t with snapshot = Some (snapshot t) } + ) else + t (* Same as [rename] except that if the source doesn't exist we delete the destination *) @@ -166,7 +223,39 @@ let rename_dir_recursively ~loc ~src_dir ~dst_dir = in loop ~src_dir ~dst_dir |> Path.Build.Set.of_list +let apply_changes_to_source_tree t ~old_snapshot = + let new_snapshot = snapshot t in + (* Same as promotion: make the file writable when copying to the source + tree. *) + let in_source_tree p = + Path.extract_build_context_dir_maybe_sandboxed p + |> Option.value_exn |> snd |> Path.source + in + let copy_file p = + let in_source_tree = in_source_tree p in + Path.unlink_no_err in_source_tree; + Option.iter (Path.parent in_source_tree) ~f:Path.mkdir_p; + Io.copy_file ~src:p ~dst:in_source_tree () + in + let delete_file p = + let in_source_tree = in_source_tree p in + Path.unlink_no_err in_source_tree + in + Path.Map.iter2 old_snapshot new_snapshot ~f:(fun p before after -> + match (before, after) with + | None, None -> assert false + | None, Some _ -> copy_file p + | Some _, None -> delete_file p + | Some before, Some after -> ( + match Cached_digest.Reduced_stats.compare before after with + | Eq -> () + | Lt + | Gt -> + copy_file p)) + let move_targets_to_build_dir t ~loc ~targets = + Option.iter t.snapshot ~f:(fun old_snapshot -> + apply_changes_to_source_tree t ~old_snapshot); let (_file_targets_renamed : unit list), files_moved_in_directory_targets = Targets.partition_map targets ~file:(fun target -> diff --git a/src/dune_engine/sandbox.mli b/src/dune_engine/sandbox.mli index f8e9e6f4a8e3..20bb7f5ae68f 100644 --- a/src/dune_engine/sandbox.mli +++ b/src/dune_engine/sandbox.mli @@ -12,6 +12,8 @@ val map_path : t -> Path.Build.t -> Path.Build.t (** Create a new sandbox and copy or link dependencies inside it. *) val create : mode:Sandbox_mode.some + -> patch_back_source_tree:bool + -> rule_loc:Loc.t -> deps:Dep.Facts.t -> rule_dir:Path.Build.t -> chdirs:Path.Set.t diff --git a/src/dune_engine/sandbox_mode.ml b/src/dune_engine/sandbox_mode.ml index 28d8ab51b3bf..0cc76a90d9c7 100644 --- a/src/dune_engine/sandbox_mode.ml +++ b/src/dune_engine/sandbox_mode.ml @@ -69,6 +69,10 @@ module Set = struct let compare = Dict.compare Bool.compare + let of_func = Dict.of_func + + let singleton k = of_func (equal k) + let equal a b = match compare a b with | Eq -> true @@ -76,8 +80,6 @@ module Set = struct | Gt -> false - let of_func = Dict.of_func - let mem = Dict.get let inter (x : t) (y : t) : t = diff --git a/src/dune_engine/sandbox_mode.mli b/src/dune_engine/sandbox_mode.mli index ffe9be19a8ae..65356e52ca9b 100644 --- a/src/dune_engine/sandbox_mode.mli +++ b/src/dune_engine/sandbox_mode.mli @@ -42,6 +42,8 @@ module Set : sig type t = bool Dict.t + val singleton : key -> t + val equal : t -> t -> bool val compare : t -> t -> Ordering.t diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index 74a04535adec..72a959a62c8c 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -1540,6 +1540,15 @@ module Rule = struct module Mode = struct include Rule.Mode + let patch_back_from_source_tree_syntax = + Dune_lang.Syntax.create ~experimental:true ~name:"patch-back-source-tree" + ~desc:"experimental support for (mode patch-back-source-tree)" + [ ((0, 1), `Since (3, 0)) ] + + let () = + Dune_project.Extension.register_simple patch_back_from_source_tree_syntax + (Dune_lang.Decoder.return []) + let decode = let promote_into lifetime = let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 8) @@ -1558,6 +1567,11 @@ module Rule = struct { lifetime = Until_clean; into = None; only = None }) ) ; ("promote-into", promote_into Unlimited) ; ("promote-until-clean-into", promote_into Until_clean) + ; ( "patch-back-source-tree" + , let+ () = + Dune_lang.Syntax.since patch_back_from_source_tree_syntax (0, 1) + in + Rule.Mode.Patch_back_source_tree ) ] let field = field "mode" decode ~default:Rule.Mode.Standard diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 7adbdc7e7886..a4906c38b91c 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -6,9 +6,10 @@ module SC = Super_context open Memo.Build.O module Alias_rules = struct - let add sctx ~alias ~loc ~locks build = + let add sctx ~alias ~loc ~locks ?patch_back_source_tree build = let dir = Alias.dir alias in - SC.add_alias_action sctx alias ~dir ~loc ~locks build + SC.add_alias_action sctx alias ~dir ~loc ~locks ?patch_back_source_tree + build let add_empty sctx ~loc ~alias = let action = Action_builder.return Action.empty in @@ -117,8 +118,14 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = | Alias_only name -> let alias = Alias.make ~dir name in let* locks = interpret_locks ~expander rule.locks in + let patch_back_source_tree = + match rule.mode with + | Patch_back_source_tree -> true + | _ -> false + in let+ () = Alias_rules.add sctx ~alias ~loc:(Some rule.loc) action.build ~locks + ~patch_back_source_tree in Targets.empty) diff --git a/src/dune_rules/simple_rules.mli b/src/dune_rules/simple_rules.mli index 40febdba0dd1..9d69193d737c 100644 --- a/src/dune_rules/simple_rules.mli +++ b/src/dune_rules/simple_rules.mli @@ -11,6 +11,7 @@ module Alias_rules : sig -> alias:Alias.t -> loc:Loc.t option -> locks:Path.t list + -> ?patch_back_source_tree:bool -> Action.t Action_builder.t -> unit Memo.Build.t diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index 87741ed01b26..6b2c77fbfaa7 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -346,11 +346,12 @@ let add_rule_get_targets t ?sandbox ?mode ?locks ?loc ~dir build = let add_rules t ?sandbox ~dir builds = Memo.Build.parallel_iter builds ~f:(add_rule t ?sandbox ~dir) -let add_alias_action t alias ~dir ~loc ?(locks = []) action = +let add_alias_action t alias ~dir ~loc ?(locks = []) + ?(patch_back_source_tree = false) action = let build = make_full_action t action ~locks ~dir in Rules.Produce.Alias.add_action ~context:(Context.build_context t.context) - alias ~loc build + alias ~loc ~patch_back_source_tree build let build_dir_is_vendored build_dir = match Path.Build.drop_build_context build_dir with diff --git a/src/dune_rules/super_context.mli b/src/dune_rules/super_context.mli index 1359c0c6e4be..f05daee90eda 100644 --- a/src/dune_rules/super_context.mli +++ b/src/dune_rules/super_context.mli @@ -137,6 +137,7 @@ val add_alias_action : -> dir:Path.Build.t -> loc:Loc.t option -> ?locks:Path.t list + -> ?patch_back_source_tree:bool -> Action.t Action_builder.t -> unit Memo.Build.t diff --git a/test/blackbox-tests/test-cases/dune b/test/blackbox-tests/test-cases/dune index bd1ad3a02b0a..abd544ce6fd5 100644 --- a/test/blackbox-tests/test-cases/dune +++ b/test/blackbox-tests/test-cases/dune @@ -143,3 +143,8 @@ (cram (applies_to hg-access) (enabled_if %{bin-available:hg}))) + +(cram + (applies_to patch-back-source-tree) + (enabled_if + (<> %{system} macosx))) diff --git a/test/blackbox-tests/test-cases/patch-back-source-tree.t b/test/blackbox-tests/test-cases/patch-back-source-tree.t new file mode 100644 index 000000000000..921f0ec190dc --- /dev/null +++ b/test/blackbox-tests/test-cases/patch-back-source-tree.t @@ -0,0 +1,186 @@ +Test for (mode patch-back-source-tree) + +It's experimental and requires enabling explicitly +-------------------------------------------------- + + $ cat >dune-project< (lang dune 3.0) + > EOF + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (action (with-stdout-to x (progn)))) + > EOF + + $ dune build + File "dune", line 2, characters 7-29: + 2 | (mode patch-back-source-tree) + ^^^^^^^^^^^^^^^^^^^^^^ + Error: 'patch-back-source-tree' is available only when patch-back-source-tree + is enabled in the dune-project file. You must enable it using (using + patch-back-source-tree 0.1) in your dune-project file. + Note however that patch-back-source-tree is experimental and might change + without notice in the future. + [1] + +----- + + $ cat >dune-project< (lang dune 3.0) + > (using patch-back-source-tree 0.1) + > EOF + +All targets are promoted +------------------------ + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (targets x) + > (action (system "echo 'Hello, world!' > x"))) + > EOF + + $ dune build x + $ cat x + Hello, world! + +All modified dependencies are promoted +-------------------------------------- + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (alias default) + > (deps x) + > (action (system "echo 'Hello, world!' > x"))) + > EOF + + $ echo blah > x + $ dune build + $ cat x + Hello, world! + +Non-modified dependencies are not promoted +------------------------------------------ + + $ rm -f x + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (alias default) + > (deps x) + > (action (system "echo 'Hello, world!'"))) + > + > (rule (with-stdout-to x (progn))) + > EOF + + $ dune build + sh alias default + Hello, world! + $ if ! test -f x; then echo ok; fi + ok + +All other new files are copied +------------------------------ + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (alias default) + > (action (system "echo 'Hello, world!' > y"))) + > EOF + + $ dune build + $ cat y + Hello, world! + +Directories are created if needed +--------------------------------- + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (alias default) + > (action (system "mkdir z; echo 'Hello, world!' > z/z"))) + > EOF + + $ dune build + $ cat z/z + Hello, world! + +Interaction with explicit sandboxing +------------------------------------ + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (deps (sandbox none)) + > (alias default) + > (action (system "echo 'Hello, world!'"))) + > EOF + + $ dune build + File "dune", line 1, characters 0-119: + 1 | (rule + 2 | (mode patch-back-source-tree) + 3 | (deps (sandbox none)) + 4 | (alias default) + 5 | (action (system "echo 'Hello, world!'"))) + Error: This rule forbids all sandboxing modes (but it also requires + sandboxing) + [1] + +Selecting an explicit sandbox mode via the command line doesn't affect +the rule: + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (alias default) + > (action (system "echo 'Hello, world!' > x"))) + > EOF + + $ test_with () + > { + > rm -f x + > dune clean + > dune build --sandbox $1 + > cat x + > } + + $ test_with copy + Hello, world! + $ test_with hardlink + Hello, world! + $ test_with symlink + Hello, world! + +Interaction with files writable status +-------------------------------------- + +If a source file is read-only, the action sees it as writable: + + $ cat >dune< (rule + > (mode patch-back-source-tree) + > (alias default) + > (deps x) + > (action (system "if test -w x; then echo writable; else echo non-writable; fi; echo blah > x"))) + > EOF + + $ echo xx > x + $ chmod -w x + + $ if test -w x; then echo writable; else echo non-writable; fi + non-writable + + $ dune build + sh alias default + writable + +And as the action modified `x`, its permissions have now changed +inside the source tree: + + $ if test -w x; then echo writable; else echo non-writable; fi + writable From ad08ad57443f70cf0217b239d52182eeb1fff83a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 1 Nov 2021 20:54:23 -0600 Subject: [PATCH 16/32] refactor: name some lazy cells makes debugging cycles easier Signed-off-by: Rudi Grinberg ps-id: B74F61F7-C8AB-46BA-9BA9-55BABE9307A9 --- src/dune_engine/build_system.ml | 4 ++-- src/dune_engine/source_tree.ml | 2 +- src/dune_rules/context.ml | 2 +- src/dune_rules/gen_rules.ml | 2 +- src/dune_rules/install_rules.ml | 2 +- src/dune_rules/scheme.ml | 18 +++++++++++------- 6 files changed, 17 insertions(+), 13 deletions(-) diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 6f1b8427a465..f5ef62304528 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -924,7 +924,7 @@ end = struct Unrestricted else Restricted - (Memo.Lazy.create (fun () -> + (Memo.Lazy.create ~name:"allowed_dirs" (fun () -> load_dir ~dir:(Path.build dir) >>| function | Non_build _ -> Dir_set.just_the_root | Build { allowed_subdirs; _ } -> @@ -2470,7 +2470,7 @@ let load_dir ~dir = load_dir_and_produce_its_rules ~dir let init ~stats ~contexts ~promote_source ~cache_config ~cache_debug_flags ~sandboxing_preference ~rule_generator ~handler ~implicit_default_alias = let contexts = - Memo.lazy_ (fun () -> + Memo.lazy_ ~name:"Build_system.init" (fun () -> let+ contexts = Memo.Lazy.force contexts in Context_name.Map.of_list_map_exn contexts ~f:(fun c -> (c.Build_context.name, c))) diff --git a/src/dune_engine/source_tree.ml b/src/dune_engine/source_tree.ml index d7023cf8bbc6..0a97891f5dd1 100644 --- a/src/dune_engine/source_tree.ml +++ b/src/dune_engine/source_tree.ml @@ -376,7 +376,7 @@ module Dir0 = struct end let ancestor_vcs = - Memo.lazy_ (fun () -> + Memo.lazy_ ~name:"ancestor_vcs" (fun () -> if Config.inside_dune then Memo.Build.return None else diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml index 7117d2596c94..76a9474a33d7 100644 --- a/src/dune_rules/context.ml +++ b/src/dune_rules/context.ml @@ -163,7 +163,7 @@ module Opam : sig val opam_binary_exn : unit -> Path.t Memo.Build.t end = struct let opam = - Memo.Lazy.create (fun () -> + Memo.Lazy.create ~name:"context-opam" (fun () -> Bin.which ~path:(Env.path Env.initial) "opam" >>= function | None -> Utils.program_not_found "opam" ~loc:None | Some opam -> ( diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index f1cf8a9cd7e0..94b550bb1a2c 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -417,7 +417,7 @@ let gen_rules ~sctx ~dir components = gen_rules ~sctx ~dir components let global_rules = - Memo.lazy_ (fun () -> + Memo.lazy_ ~name:"global-rules" (fun () -> Rules.collect_unit (fun () -> let* sctxs = Memo.Lazy.force Super_context.all in Memo.Build.parallel_iter diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 103b2b03a938..d723ff26f6cf 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -928,7 +928,7 @@ let memo = (let ctx = Super_context.context sctx in let context_name = ctx.name in let rules = - Memo.lazy_ (fun () -> + Memo.lazy_ ~name:"install-rules-and-pkg-entries-rules" (fun () -> Rules.collect_unit (fun () -> let* () = install_rules sctx pkg in install_alias ctx pkg)) diff --git a/src/dune_rules/scheme.ml b/src/dune_rules/scheme.ml index 691b121f6573..7e7ab898c2c9 100644 --- a/src/dune_rules/scheme.ml +++ b/src/dune_rules/scheme.ml @@ -44,12 +44,12 @@ end = struct { by_child = String.Map.union x.by_child y.by_child ~f:(fun _key data1 data2 -> Some - (Memo.Lazy.create (fun () -> + (Memo.Lazy.create ~name:"scheme-union" (fun () -> let+ x = Memo.Lazy.force data1 and+ y = Memo.Lazy.force data2 in union ~union_rules x y))) ; rules_here = - Memo.lazy_ (fun () -> + Memo.lazy_ ~name:"union-rules-here" (fun () -> let+ x = Memo.Lazy.force x.rules_here and+ y = Memo.Lazy.force y.rules_here in Option.merge x y ~f:union_rules) @@ -59,7 +59,7 @@ end = struct _ t Memo.Build.t = let rules_here = if Dir_set.here dirs then - Memo.Lazy.create (fun () -> + Memo.Lazy.create ~name:"restrict-rules-here" (fun () -> let* t = Memo.Lazy.force t in Memo.Lazy.force t.rules_here) else @@ -73,13 +73,15 @@ end = struct committed to supporting this case though, anyway. *) let+ t = Memo.Lazy.force t in String.Map.mapi t.by_child ~f:(fun dir v -> - Memo.lazy_ (fun () -> restrict (Dir_set.descend dirs dir) v)) + Memo.lazy_ ~name:"restrict-by-child-default" (fun () -> + restrict (Dir_set.descend dirs dir) v)) | false -> Memo.Build.return (String.Map.mapi (Dir_set.exceptions dirs) ~f:(fun dir v -> - Memo.lazy_ (fun () -> + Memo.lazy_ ~name:"restrict-by-child-non-default-outer" (fun () -> restrict v - (Memo.lazy_ (fun () -> + (Memo.lazy_ ~name:"restrict-by-child-non-default-inner" + (fun () -> let* t = Memo.Lazy.force t in descend t dir))))) in @@ -134,7 +136,9 @@ let evaluate ~union_rules = [ ("inner", Dir_set.to_dyn paths); ("outer", Dir_set.to_dyn env) ] else let paths = Dir_set.inter paths env in - Evaluated.restrict paths (Memo.lazy_ (fun () -> loop ~env:paths rules)) + Evaluated.restrict paths + (Memo.lazy_ ~name:"evaluate-restrict" (fun () -> + loop ~env:paths rules)) | Finite rules -> let violations = List.filter (Path.Build.Map.keys rules) ~f:(fun p -> From 32cf84601340949aefbaed9095f374e98a9c6c39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 2 Nov 2021 14:38:45 +0000 Subject: [PATCH 17/32] Don't print the short display when not in short display mode (#5074) And refactor the printing code for command outcomes. Signed-off-by: Jeremie Dimino --- .../depend-on-directory-without-targets/run.t | 1 - .../dependency-rebuilt-but-not-changed/run.t | 1 - .../test/depends-on-directory-with-glob/run.t | 1 - .../do-not-rebuild-unneeded-dependency/run.t | 2 - .../action-plugin/test/no-dependencies/run.t | 1 - .../test/one-dependency-with-chdir/run.t | 1 - .../action-plugin/test/one-dependency/run.t | 1 - .../test/one-directory-dependency/run.t | 1 - .../test/one-undeclared-target/run.t | 2 - .../test/ordinary-executable/run.t | 1 - .../test/two-stages-dependency-choose/run.t | 1 - otherlibs/site/test/run.t | 1 - src/dune_engine/process.ml | 258 ++++++++++-------- .../actions/action-stdxxx-on-success.t | 26 -- .../test-cases/cinaps/include-subdirs.t/run.t | 2 - .../test-cases/cinaps/simple.t/run.t | 4 - .../test-cases/cxx-extension.t/run.t | 3 - .../test-cases/depend-on/dep-on-alias.t/run.t | 7 - .../depend-on/installed-packages.t/run.t | 2 - .../depend-on/no-deps-in-cwd.t/run.t | 2 - .../test-cases/dialects.t/run.t | 2 - .../test-cases/dir-target-dep.t/run.t | 1 - .../test-cases/directory-targets/main.t | 12 - test/blackbox-tests/test-cases/display.t | 16 +- .../test-cases/dune-cache/mode-copy.t/run.t | 4 - .../dune-cache/mode-hardlink.t/run.t | 4 - .../test-cases/dune-ppx-driver-system.t/run.t | 5 - .../test-cases/env/env-bin-pform.t/run.t | 1 - .../test-cases/env/env-bins.t/run.t | 7 - .../env/env-dune-file.t/flag-field/dune | 4 +- .../test-cases/env/env-dune-file.t/run.t | 6 +- .../test-cases/env/env-tracking.t/run.t | 3 - .../test-cases/exe-name-mangle.t/run.t | 2 - .../test-cases/force-test.t/run.t | 2 - .../test-cases/github1616.t/run.t | 1 - .../test-cases/github2228.t/run.t | 1 - .../test-cases/github3490.t/run.t | 1 - .../test-cases/github568.t/run.t | 2 +- .../test-cases/github660.t/run.t | 4 - .../test-cases/glob_files_rec.t/run.t | 3 +- .../inline_tests-multi-mode.t/run.t | 2 - .../test-cases/inline_tests/dune-file.t/run.t | 2 - .../inline_tests/executable-flags.t/run.t | 1 - .../inline_tests/many-backends-choose.t/run.t | 1 - .../multiple-inline-tests.t/run.t | 2 - .../test-cases/inline_tests/simple.t/run.t | 4 - .../test-cases/jsoo/inline-tests.t/run.t | 3 - .../test-cases/multi-dir.t/run.t | 2 - .../test-cases/odoc/warnings.t/run.t | 4 +- .../test-cases/output-obj.t/run.t | 4 - .../test-cases/package-dep.t/run.t | 1 - .../test-cases/path-rewriting.t | 2 - .../test-cases/pipe-actions.t/run.t | 1 - .../test-cases/ppx-rewriter.t/run.t | 1 - .../test-cases/private-modules.t/run.t | 1 - .../blackbox-tests/test-cases/quoting.t/run.t | 1 - test/blackbox-tests/test-cases/reason.t/run.t | 1 - .../test-cases/report-all-errors.t | 6 +- test/blackbox-tests/test-cases/select.t/run.t | 2 - .../test-cases/tests-stanza-action.t/run.t | 2 - .../test-cases/tests-stanza.t/run.t | 3 - .../test-cases/vendor/main.t/run.t | 1 - .../impl-private-modules.t/run.t | 1 - .../impl-using-vlib-modules.t/run.t | 1 - .../implements-external.t/run.t | 4 - .../virtual-libraries/preprocess.t/run.t | 1 - .../private-modules-overlapping-names.t/run.t | 1 - .../virtual-libraries/unwrapped.t/run.t | 2 - .../virtual-libraries/variants-simple.t/run.t | 1 - .../variants-sub-module.t/run.t | 1 - .../vlib-default-impl.t/run.t | 2 - .../test-cases/with-exit-codes.t/run.t | 2 - .../test-cases/with-nested-exit-codes.t/run.t | 1 - .../test-cases/workspace-paths.t/run.t | 1 - .../dune_rpc_e2e/dune_rpc_diagnostics.ml | 1 - 75 files changed, 157 insertions(+), 308 deletions(-) diff --git a/otherlibs/action-plugin/test/depend-on-directory-without-targets/run.t b/otherlibs/action-plugin/test/depend-on-directory-without-targets/run.t index c7d8db1b1660..1ee23d2dd8ba 100644 --- a/otherlibs/action-plugin/test/depend-on-directory-without-targets/run.t +++ b/otherlibs/action-plugin/test/depend-on-directory-without-targets/run.t @@ -18,5 +18,4 @@ $ cp ./bin/foo.exe ./ $ dune runtest - foo alias runtest Directory listing: [some_file1; some_file2] diff --git a/otherlibs/action-plugin/test/dependency-rebuilt-but-not-changed/run.t b/otherlibs/action-plugin/test/dependency-rebuilt-but-not-changed/run.t index 21a98b7ea163..470b8acb41ca 100644 --- a/otherlibs/action-plugin/test/dependency-rebuilt-but-not-changed/run.t +++ b/otherlibs/action-plugin/test/dependency-rebuilt-but-not-changed/run.t @@ -25,7 +25,6 @@ they were forced to rebuild. $ dune runtest Building some_file! - foo alias runtest Hello from some_file! $ dune runtest diff --git a/otherlibs/action-plugin/test/depends-on-directory-with-glob/run.t b/otherlibs/action-plugin/test/depends-on-directory-with-glob/run.t index a68732b664a2..3287a40534c2 100644 --- a/otherlibs/action-plugin/test/depends-on-directory-with-glob/run.t +++ b/otherlibs/action-plugin/test/depends-on-directory-with-glob/run.t @@ -39,6 +39,5 @@ $ dune runtest Building some_file! Building some_file_but_different! - foo alias runtest some_file some_file_but_different diff --git a/otherlibs/action-plugin/test/do-not-rebuild-unneeded-dependency/run.t b/otherlibs/action-plugin/test/do-not-rebuild-unneeded-dependency/run.t index 2f9539ecb502..0f599b7dc673 100644 --- a/otherlibs/action-plugin/test/do-not-rebuild-unneeded-dependency/run.t +++ b/otherlibs/action-plugin/test/do-not-rebuild-unneeded-dependency/run.t @@ -45,7 +45,6 @@ only the dependencies up to this stage are rebuilt. $ dune runtest Building foo_or_bar! Building foo! - client alias runtest Hello from foo! $ printf "bar" > foo_or_bar_source @@ -55,5 +54,4 @@ only the dependencies up to this stage are rebuilt. $ dune runtest Building foo_or_bar! Building bar! - client alias runtest Hello from bar! diff --git a/otherlibs/action-plugin/test/no-dependencies/run.t b/otherlibs/action-plugin/test/no-dependencies/run.t index cff1aa4f8680..ee5f269041bf 100644 --- a/otherlibs/action-plugin/test/no-dependencies/run.t +++ b/otherlibs/action-plugin/test/no-dependencies/run.t @@ -16,5 +16,4 @@ but requires no dependencies can be successfully run. $ cp ./bin/foo.exe ./ $ dune runtest - foo alias runtest Hello from foo! diff --git a/otherlibs/action-plugin/test/one-dependency-with-chdir/run.t b/otherlibs/action-plugin/test/one-dependency-with-chdir/run.t index a8752c8658e3..5f0fb0a8dfa2 100644 --- a/otherlibs/action-plugin/test/one-dependency-with-chdir/run.t +++ b/otherlibs/action-plugin/test/one-dependency-with-chdir/run.t @@ -25,5 +25,4 @@ when we 'chdir' into different directory. $ cp ./bin/foo.exe ./some_dir $ dune runtest - foo alias runtest Hello from some_dependency! diff --git a/otherlibs/action-plugin/test/one-dependency/run.t b/otherlibs/action-plugin/test/one-dependency/run.t index b5393fc0cccc..e5dc04f0fc2c 100644 --- a/otherlibs/action-plugin/test/one-dependency/run.t +++ b/otherlibs/action-plugin/test/one-dependency/run.t @@ -19,5 +19,4 @@ and requires one dependency can be successfully run. $ cp ./bin/foo.exe ./ $ dune runtest - foo alias runtest Hello from some_dependency! diff --git a/otherlibs/action-plugin/test/one-directory-dependency/run.t b/otherlibs/action-plugin/test/one-directory-dependency/run.t index d9214a15e65d..a018bbb0d717 100644 --- a/otherlibs/action-plugin/test/one-directory-dependency/run.t +++ b/otherlibs/action-plugin/test/one-directory-dependency/run.t @@ -32,7 +32,6 @@ directory to be build. $ cp ./bin/foo.exe ./ $ dune runtest - foo alias runtest dune some_file1 some_file2 diff --git a/otherlibs/action-plugin/test/one-undeclared-target/run.t b/otherlibs/action-plugin/test/one-undeclared-target/run.t index d0fd8f9910a2..b9b7950428b8 100644 --- a/otherlibs/action-plugin/test/one-undeclared-target/run.t +++ b/otherlibs/action-plugin/test/one-undeclared-target/run.t @@ -16,7 +16,5 @@ 1 | (rule 2 | (alias runtest) 3 | (action (dynamic-run ./foo.exe))) - foo alias runtest (exit 1) - (cd _build/default && ./foo.exe) bar is written despite not being declared as a target in dune file. To fix, add it to target list in dune file. [1] diff --git a/otherlibs/action-plugin/test/ordinary-executable/run.t b/otherlibs/action-plugin/test/ordinary-executable/run.t index c40fcc14cfa7..2401dfc2df4c 100644 --- a/otherlibs/action-plugin/test/ordinary-executable/run.t +++ b/otherlibs/action-plugin/test/ordinary-executable/run.t @@ -15,7 +15,6 @@ ordinary executable instead of one linked against dune-action-plugin. $ cp ./bin/foo.exe ./ $ dune runtest - foo alias runtest Hello from foo! File "dune", line 1, characters 0-57: 1 | (rule diff --git a/otherlibs/action-plugin/test/two-stages-dependency-choose/run.t b/otherlibs/action-plugin/test/two-stages-dependency-choose/run.t index 39d760f55283..d325844f3aca 100644 --- a/otherlibs/action-plugin/test/two-stages-dependency-choose/run.t +++ b/otherlibs/action-plugin/test/two-stages-dependency-choose/run.t @@ -34,5 +34,4 @@ on based on dependency from the previous stage. $ dune runtest Building bar! - client alias runtest Hello from bar! diff --git a/otherlibs/site/test/run.t b/otherlibs/site/test/run.t index 6144f75edca5..66474dbf20b9 100644 --- a/otherlibs/site/test/run.t +++ b/otherlibs/site/test/run.t @@ -358,7 +358,6 @@ Test compiling an external plugin run c: registered:e,b. $ OCAMLPATH=_install/lib:$OCAMLPATH dune build @runtest - c alias e/runtest run a a: $TESTCASE_ROOT/_build/install/default/share/a/data run c: a linked registered:. diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index fc4182d9ff5e..644f94024a14 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -209,6 +209,14 @@ let command_line ~prog ~args ~dir ~stdout_to ~stderr_to ~stdin_from = in prefix ^ s ^ suffix +module Exit_status = struct + type error = + | Failed of int + | Signaled of string + + type t = (int, error) result +end + module Fancy = struct let split_prog s = let len = String.length s in @@ -241,6 +249,10 @@ module Fancy = struct let prog = String.sub s ~pos:prog_start ~len:(prog_end - prog_start) in (before, prog, after) + let short_prog_name_of_prog s = + let _, s, _ = split_prog s in + s + let color_combos = let open Ansi_color.Style in [| [ fg_blue; bg_bright_green ] @@ -285,7 +297,20 @@ module Fancy = struct command_line_enclosers ~dir ~stdout_to ~stderr_to ~stdin_from in Pp.verbatim prefix ++ pp ++ Pp.verbatim suffix +end +(* Implemt the rendering for [--display short] *) +module Short_display : sig + val pp_ok : prog:string -> purpose:purpose -> User_message.Style.t Pp.t + + val pp_error : + prog:string + -> purpose:purpose + -> has_unexpected_stdout:bool + -> has_unexpected_stderr:bool + -> error:Exit_status.error + -> User_message.Style.t Pp.t +end = struct let pp_purpose = function | Internal_job _ -> Pp.verbatim "(internal)" | Build_job (_, _, targets) -> ( @@ -345,6 +370,36 @@ module Fancy = struct ++ Pp.concat_map l ~sep:(Pp.char ',') ~f:(fun ctx -> Pp.verbatim (Context_name.to_string ctx)) ++ Pp.char ']')) + + let progname_and_purpose ~tag ~prog ~purpose = + let open Pp.O in + let progname = sprintf "%12s" (Fancy.short_prog_name_of_prog prog) in + Pp.tag tag (Pp.verbatim progname) ++ Pp.char ' ' ++ pp_purpose purpose + + let pp_ok = progname_and_purpose ~tag:Ok + + let pp_error ~prog ~purpose ~has_unexpected_stdout ~has_unexpected_stderr + ~(error : Exit_status.error) = + let open Pp.O in + let msg = + match error with + | Signaled signame -> sprintf "(got signal %s)" signame + | Failed n -> ( + let unexpected_outputs = + List.filter_map + [ (has_unexpected_stdout, "stdout") + ; (has_unexpected_stderr, "stderr") + ] ~f:(fun (b, name) -> Option.some_if b name) + in + match (n, unexpected_outputs) with + | 0, _ :: _ -> + sprintf "(had unexpected output on %s)" + (String.enumerate_and unexpected_outputs) + | _ -> sprintf "(exit %d)" n) + in + progname_and_purpose ~prog ~tag:Error ~purpose + ++ Pp.char ' ' + ++ Pp.tag User_message.Style.Error (Pp.verbatim msg) end let gen_id = @@ -361,14 +416,10 @@ let pp_id id = let open Pp.O in Pp.char '[' ++ Pp.tag User_message.Style.Id (Pp.textf "%d" id) ++ Pp.char ']' -module Exit_status : sig - type error = - | Failed of int - | Signaled of string +module Handle_exit_status : sig + open Exit_status - type t = (int, error) result - - val handle_verbose : + val verbose : ('a, error) result -> id:int -> purpose:purpose @@ -377,7 +428,7 @@ module Exit_status : sig -> dir:With_directory_annot.payload option -> 'a - val handle_non_verbose : + val non_verbose : ('a, error) result -> verbosity:Scheduler.Config.Display.verbosity -> purpose:purpose @@ -389,11 +440,7 @@ module Exit_status : sig -> has_unexpected_stderr:bool -> 'a end = struct - type error = - | Failed of int - | Signaled of string - - type t = (int, error) result + open Exit_status type output = | No_output @@ -403,9 +450,9 @@ end = struct ; has_embedded_location : bool } - let has_embedded_location = function - | No_output -> false - | Has_output t -> t.has_embedded_location + let pp_output = function + | No_output -> [] + | Has_output t -> [ t.with_color ] let parse_output = function | "" -> No_output @@ -420,38 +467,33 @@ end = struct in Has_output { with_color; without_color; has_embedded_location } - (* In this module, we don't need the "Error: " prefix given that it is already - included in the error message from the command. *) - let fail ~output ~purpose ~dir paragraphs = - let paragraphs : User_message.Style.t Pp.t list = - match output with - | No_output -> paragraphs - | Has_output output -> paragraphs @ [ output.with_color ] - in - let dir = - match dir with - | None -> Path.of_string (Sys.getcwd ()) - | Some dir -> dir - in + let get_loc_and_annots ~dir ~purpose ~output = let loc, annots = loc_and_annots_of_purpose purpose in + let dir = Option.value dir ~default:Path.root in let annots = With_directory_annot.make dir :: annots in let annots = - if has_embedded_location output then - let annots = User_error.Annot.Has_embedded_location.make () :: annots in - match - match output with - | No_output -> None - | Has_output output -> - Compound_user_error.parse_output ~dir output.without_color - with - | None -> annots - | Some annot -> annot :: annots - else - annots + match output with + | No_output -> annots + | Has_output output -> + if output.has_embedded_location then + let annots = + User_error.Annot.Has_embedded_location.make () :: annots + in + match Compound_user_error.parse_output ~dir output.without_color with + | None -> annots + | Some annot -> annot :: annots + else + annots in + (loc, annots) + + let fail ~loc ~annots paragraphs = + (* We don't use [User_error.make] as it would add the "Error: " prefix. We + don't need this prefix as it is already included in the output of the + command. *) raise (User_error.E (User_message.make ?loc paragraphs, annots)) - let handle_verbose t ~id ~purpose ~output ~command_line ~dir = + let verbose t ~id ~purpose ~output ~command_line ~dir = let open Pp.O in let output = parse_output output in match t with @@ -472,86 +514,70 @@ end = struct | Failed n -> sprintf "exited with code %d" n | Signaled signame -> sprintf "got signal %s" signame in - fail ~output ~purpose ~dir - [ Pp.tag User_message.Style.Kwd (Pp.verbatim "Command") - ++ Pp.space ++ pp_id id ++ Pp.space ++ Pp.text msg ++ Pp.char ':' - ; Pp.tag User_message.Style.Prompt (Pp.char '$') - ++ Pp.char ' ' ++ command_line - ] - - let handle_non_verbose t ~verbosity ~purpose ~output ~prog ~command_line ~dir - ~has_unexpected_stdout ~has_unexpected_stderr = - let open Pp.O in + let loc, annots = get_loc_and_annots ~dir ~purpose ~output in + fail ~loc ~annots + (Pp.tag User_message.Style.Kwd (Pp.verbatim "Command") + ++ Pp.space ++ pp_id id ++ Pp.space ++ Pp.text msg ++ Pp.char ':' + :: Pp.tag User_message.Style.Prompt (Pp.char '$') + ++ Pp.char ' ' ++ command_line + :: pp_output output) + + let non_verbose t ~(verbosity : Scheduler.Config.Display.verbosity) ~purpose + ~output ~prog ~command_line ~dir ~has_unexpected_stdout + ~has_unexpected_stderr = let output = parse_output output in - let has_embedded_location = has_embedded_location output in let show_command = - let show_full_command_on_error = - !Clflags.always_show_command_line - || (* We want to show command lines in the CI, but not when running - inside dune. Otherwise tests would yield different result whether - they are executed locally or in the CI. *) - (Config.inside_ci && not Config.inside_dune) - in - show_full_command_on_error || not has_embedded_location + !Clflags.always_show_command_line + || (* We want to show command lines in the CI, but not when running inside + dune. Otherwise tests would yield different result whether they are + executed locally or in the CI. *) + (Config.inside_ci && not Config.inside_dune) in - let _, progname, _ = Fancy.split_prog prog in - let progname_and_purpose tag = - let progname = sprintf "%12s" progname in - Pp.tag tag (Pp.verbatim progname) - ++ Pp.char ' ' ++ Fancy.pp_purpose purpose + let add_command_line paragraphs = + if show_command then + Pp.tag User_message.Style.Details (Pp.verbatim command_line) + :: paragraphs + else + paragraphs in match t with | Ok n -> - (if - (match output with - | No_output -> false - | Has_output _ -> true) - || (match verbosity with - | Scheduler.Config.Display.Short -> true - | Quiet -> false - | Verbose -> assert false) - && - match purpose with - | Internal_job _ -> false - | Build_job _ -> true - then - let output = - match output with - | No_output -> [] - | Has_output output -> [ output.with_color ] - in - Console.print_user_message - (User_message.make - (if show_command then - progname_and_purpose Ok :: output - else - output))); + let paragraphs = + match output with + | No_output -> [] + | Has_output output -> add_command_line [ output.with_color ] + in + let paragraphs = + match (verbosity, purpose, output) with + | Short, Build_job _, _ + | Short, Internal_job _, Has_output _ -> + Short_display.pp_ok ~prog ~purpose :: paragraphs + | _ -> paragraphs + in + if not (List.is_empty paragraphs) then + Console.print_user_message (User_message.make paragraphs); n - | Error err -> - let msg = - match err with - | Signaled signame -> sprintf "(got signal %s)" signame - | Failed n -> - if show_command then - let unexpected_outputs = - List.filter_map - [ (has_unexpected_stdout, "stdout") - ; (has_unexpected_stderr, "stderr") - ] ~f:(fun (b, name) -> Option.some_if b name) - in - match (n, unexpected_outputs) with - | 0, _ :: _ -> - sprintf "(had unexpected output on %s)" - (String.enumerate_and unexpected_outputs) - | _ -> sprintf "(exit %d)" n - else - fail ~output ~purpose ~dir [] + | Error error -> + let loc, annots = get_loc_and_annots ~dir ~purpose ~output in + let paragraphs = + match verbosity with + | Short -> + Short_display.pp_error ~prog ~purpose ~error ~has_unexpected_stdout + ~has_unexpected_stderr + :: add_command_line (pp_output output) + | _ -> + add_command_line + (match output with + | Has_output output -> [ output.with_color ] + | No_output -> ( + (* If the command has no output, we need to say something. + Otherwise it's not clear what's going on. *) + match error with + | Failed n -> [ Pp.textf "Command exited with code %d." n ] + | Signaled signame -> + [ Pp.textf "Command got signal %s." signame ])) in - fail ~output ~purpose ~dir - [ progname_and_purpose Error ++ Pp.char ' ' - ++ Pp.tag User_message.Style.Error (Pp.verbatim msg) - ; Pp.tag User_message.Style.Details (Pp.verbatim command_line) - ] + fail ~loc ~annots paragraphs end let report_process_start stats ~id ~prog ~args ~now = @@ -778,10 +804,10 @@ let run_internal ?dir ?(stdout_to = Io.stdout) ?(stderr_to = Io.stderr) match (display.verbosity, exit_status', output) with | Quiet, Ok n, "" -> n (* Optimisation for the common case *) | Verbose, _, _ -> - Exit_status.handle_verbose exit_status' ~id ~purpose ~dir + Handle_exit_status.verbose exit_status' ~id ~purpose ~dir ~command_line:fancy_command_line ~output | _ -> - Exit_status.handle_non_verbose exit_status' ~prog:prog_str ~dir + Handle_exit_status.non_verbose exit_status' ~prog:prog_str ~dir ~command_line ~output ~purpose ~verbosity:display.verbosity ~has_unexpected_stdout ~has_unexpected_stderr in diff --git a/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t b/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t index 2dc5e2eac25b..7537231df244 100644 --- a/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t +++ b/test/blackbox-tests/test-cases/actions/action-stdxxx-on-success.t @@ -22,9 +22,7 @@ Test for --action-stdxxx-on-success By default, stdout and stderr are always printed: $ dune build - sh alias default Hello, world! - sh alias default Something went wrong! swallow tests @@ -44,27 +42,21 @@ printing the output of the action that had a non-empty output. $ dune clean $ dune build --action-stdout-on-success=must-be-empty - sh alias default Something went wrong! File "dune", line 1, characters 0-65: 1 | (rule 2 | (alias default) 3 | (action (system "echo 'Hello, world!'"))) - sh alias default (had unexpected output on stdout) - (cd _build/default && sh -c 'echo '\''Hello, world!'\''') Hello, world! [1] $ dune clean $ dune build --action-stderr-on-success=must-be-empty - sh alias default Hello, world! File "dune", line 5, characters 0-77: 5 | (rule 6 | (alias default) 7 | (action (system "echo 'Something went wrong!' >&2"))) - sh alias default (had unexpected output on stderr) - (cd _build/default && sh -c 'echo '\''Something went wrong!'\'' >&2') Something went wrong! [1] @@ -78,8 +70,6 @@ Same but with output on both stdout and stderr: 9 | (rule 10 | (alias both-stdout-and-stderr-output) 11 | (action (system "echo stdout; echo stderr >&2"))) - sh alias both-stdout-and-stderr-output (had unexpected output on stdout and stderr) - (cd _build/default && sh -c 'echo stdout; echo stderr >&2') stdout stderr [1] @@ -102,9 +92,7 @@ it, actions that printed something to stdout or stderr are re-executed: $ dune build - sh alias default Hello, world! - sh alias default Something went wrong! However, we currently re-execute too much. In particular, we @@ -122,19 +110,15 @@ re-execute actions whose outcome is not affected by the change: $ dune clean $ dune build --action-stdout-on-success=swallow - sh alias default a.stderr - sh alias default b.stderr You can observe in the below call that both actions are being re-executed: $ dune build - sh alias default a.stdout a.stderr - sh alias default b.stderr However, re-executing the second action was not necessary given that @@ -160,8 +144,6 @@ In case of errors, we print everything no matter what. 1 | (rule 2 | (alias default) 3 | (action (system "echo 'Hello, world!'; exit 1"))) - sh alias default (exit 1) - (cd _build/default && sh -c 'echo '\''Hello, world!'\''; exit 1') Hello, world! [1] @@ -171,8 +153,6 @@ In case of errors, we print everything no matter what. 1 | (rule 2 | (alias default) 3 | (action (system "echo 'Hello, world!'; exit 1"))) - sh alias default (exit 1) - (cd _build/default && sh -c 'echo '\''Hello, world!'\''; exit 1') Hello, world! [1] @@ -182,8 +162,6 @@ In case of errors, we print everything no matter what. 1 | (rule 2 | (alias default) 3 | (action (system "echo 'Hello, world!'; exit 1"))) - sh alias default (exit 1) - (cd _build/default && sh -c 'echo '\''Hello, world!'\''; exit 1') Hello, world! [1] @@ -210,8 +188,6 @@ first command but not the second: 4 | (progn 5 | (system "echo 1") 6 | (system "echo 2; exit 1")))) - sh alias default (exit 1) - (cd _build/default && sh -c 'echo 2; exit 1') 2 [1] @@ -236,8 +212,6 @@ better if we stop at the end of the whole action. 4 | (progn 5 | (system "echo 1") 6 | (system "echo 2")))) - sh alias default (had unexpected output on stdout) - (cd _build/default && sh -c 'echo 1') 1 [1] diff --git a/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t b/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t index ccf10876fffd..02bd40beded8 100644 --- a/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t +++ b/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t @@ -22,8 +22,6 @@ cinaps doesn't work with (include_subdirs unqualified) $ dune runtest --diff-command diff 2>&1 | sed -E 's/[^ ]+sh/\$sh/' File "sub/test.ml", line 1, characters 0-0: - sh (internal) (exit 1) - (cd _build/default && $sh -c 'diff sub/test.ml sub/test.ml.cinaps-corrected') 2,3c2 < (*) < let x = 1 diff --git a/test/blackbox-tests/test-cases/cinaps/simple.t/run.t b/test/blackbox-tests/test-cases/cinaps/simple.t/run.t index f3ee34bd99e9..028bf59915f4 100644 --- a/test/blackbox-tests/test-cases/cinaps/simple.t/run.t +++ b/test/blackbox-tests/test-cases/cinaps/simple.t/run.t @@ -19,8 +19,6 @@ The cinaps actions should be attached to the runtest alias: $ dune runtest --diff-command diff 2>&1 | sed -E 's/[^ ]+sh/\$sh/' File "test.ml", line 1, characters 0-0: - sh (internal) (exit 1) - (cd _build/default && $sh -c 'diff test.ml test.ml.cinaps-corrected') 1a2 > hello @@ -28,8 +26,6 @@ but also to the cinaps alias: $ dune build @cinaps --diff-command diff 2>&1 | sed -E 's/[^ ]+sh/\$sh/' File "test.ml", line 1, characters 0-0: - sh (internal) (exit 1) - (cd _build/default && $sh -c 'diff test.ml test.ml.cinaps-corrected') 1a2 > hello diff --git a/test/blackbox-tests/test-cases/cxx-extension.t/run.t b/test/blackbox-tests/test-cases/cxx-extension.t/run.t index cb44862cdae2..d106a21cd6b5 100644 --- a/test/blackbox-tests/test-cases/cxx-extension.t/run.t +++ b/test/blackbox-tests/test-cases/cxx-extension.t/run.t @@ -21,7 +21,6 @@ * .cxx extension is allowed $ dune build - bar alias default n = 42 $ echo "(lang dune 1.11)" > dune-project @@ -44,7 +43,6 @@ $ dune clean $ dune build - bar alias default n = 42 * Compilation fails when baz.cpp and baz.cxx conflict @@ -100,7 +98,6 @@ This works because the translation layer from pre-2.0 to 2.0 replaces $ dune clean $ dune build - bar alias default n = 42 * Compilation fails when using :standard in Dune 2.0 diff --git a/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t/run.t b/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t/run.t index 6bef34103991..3443409f05b9 100644 --- a/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t/run.t +++ b/test/blackbox-tests/test-cases/depend-on/dep-on-alias.t/run.t @@ -23,18 +23,15 @@ > ) > EOF $ dune build @b - bash alias b running b: old-contents $ dune build @b $ echo new-contents > x $ dune build @b - bash alias b running b: new-contents ^ dune does re-run the action when a dependency declared via an alias changes. And the path does appear in the sandbox: $ dune build @b --sandbox copy 2>&1 | grep -v 'cd _build/.sandbox' - bash alias b running b: new-contents However, this is only since 3.0, before that aliases where not @@ -49,7 +46,6 @@ expanded when creating the sandbox: 7 | (deps (alias a)) 8 | (action (bash "echo -n \"running b: \"; cat x")) 9 | ) - bash alias b (exit 1) running b: cat: x: No such file or directory $ cat >dune-project < (lang dune 3.0) @@ -79,14 +75,11 @@ Now test that including an alias into another alias includes its expansion: $ rm -r _build $ echo old-contents > x $ dune build @b - bash alias b running b: old-contents $ dune build @b $ echo new-contents > x $ dune build @b - bash alias b running b: new-contents The path still does appear in the sandbox: $ dune build @b --sandbox copy 2>&1 | grep -v 'cd _build/.sandbox' - bash alias b running b: new-contents diff --git a/test/blackbox-tests/test-cases/depend-on/installed-packages.t/run.t b/test/blackbox-tests/test-cases/depend-on/installed-packages.t/run.t index 7a63c526c13d..abf3ce6cac21 100644 --- a/test/blackbox-tests/test-cases/depend-on/installed-packages.t/run.t +++ b/test/blackbox-tests/test-cases/depend-on/installed-packages.t/run.t @@ -35,7 +35,6 @@ $ OCAMLPATH=$(pwd)/prefix/lib/:$OCAMLPATH dune build --root b @runtest Entering directory 'b' - cat alias runtest Miaou $ OCAMLPATH=$(pwd)/prefix/lib/:$OCAMLPATH dune build --root b @runtest @@ -60,7 +59,6 @@ $ OCAMLPATH=$(pwd)/prefix/lib/:$OCAMLPATH dune build --root b @runtest Entering directory 'b' - cat alias runtest Ouaf $ OCAMLPATH=$(pwd)/prefix/lib/:$OCAMLPATH dune build --root b @runtest diff --git a/test/blackbox-tests/test-cases/depend-on/no-deps-in-cwd.t/run.t b/test/blackbox-tests/test-cases/depend-on/no-deps-in-cwd.t/run.t index d3a08776fda0..e246119bcc55 100644 --- a/test/blackbox-tests/test-cases/depend-on/no-deps-in-cwd.t/run.t +++ b/test/blackbox-tests/test-cases/depend-on/no-deps-in-cwd.t/run.t @@ -16,7 +16,6 @@ and dune makes sure that the directory exists inside the sandbox. > ) > EOF $ dune build @a --sandbox=copy - bash alias a/a contents $ cat >dune < ) > EOF $ dune build @root --sandbox=copy - bash alias root contents diff --git a/test/blackbox-tests/test-cases/dialects.t/run.t b/test/blackbox-tests/test-cases/dialects.t/run.t index 3b6e3b2dd8f9..277baf291643 100644 --- a/test/blackbox-tests/test-cases/dialects.t/run.t +++ b/test/blackbox-tests/test-cases/dialects.t/run.t @@ -5,9 +5,7 @@ Test the (dialect ...) stanza inside the dune-project file. $ dune build --root good @fmt Entering directory 'good' - fmt .formatted/main.mf Formatting main.mf - fmt .formatted/main.mfi Formatting main.mfi $ dune build --root bad1 diff --git a/test/blackbox-tests/test-cases/dir-target-dep.t/run.t b/test/blackbox-tests/test-cases/dir-target-dep.t/run.t index 64d44e777f99..d8f33c1d207c 100644 --- a/test/blackbox-tests/test-cases/dir-target-dep.t/run.t +++ b/test/blackbox-tests/test-cases/dir-target-dep.t/run.t @@ -5,7 +5,6 @@ $ dune build --root target @cat_dir Entering directory 'target' - cat_dir alias cat_dir bar: bar contents diff --git a/test/blackbox-tests/test-cases/directory-targets/main.t b/test/blackbox-tests/test-cases/directory-targets/main.t index d93f6bc95a83..e32fcccce657 100644 --- a/test/blackbox-tests/test-cases/directory-targets/main.t +++ b/test/blackbox-tests/test-cases/directory-targets/main.t @@ -238,7 +238,6 @@ the subdirectories included into the directory target. # CR-someday amokhov: Remove the files that action didn't depend on. $ dune build level1 - bash level1 output/a.txt output/b.txt $ cat _build/default/level1 @@ -250,7 +249,6 @@ the subdirectories included into the directory target. Depending on a glob in a subdirectory of a directory target works too. $ dune build level2 - bash level2 output/subdir/d.txt output/subdir/e $ cat _build/default/level2 d.txt @@ -292,9 +290,7 @@ rule to rerun when needed. $ echo b > src_b $ echo c > src_c $ dune build contents - bash output running - bash contents running $ cat _build/default/contents a: @@ -309,9 +305,7 @@ mtime changes when the rule reruns. We can delete this when switching to (1). $ echo new-b > src_b $ dune build contents - bash output running - bash contents running $ cat _build/default/contents a: @@ -325,9 +319,7 @@ skip the second action since the produced directory has the same contents. $ dune_cmd wait-for-fs-clock-to-advance $ echo new-cc > src_c $ dune build contents - bash output running - bash contents running $ cat _build/default/contents a: @@ -342,9 +334,7 @@ and the second one because of the lack of early cutoff. $ dune_cmd wait-for-fs-clock-to-advance $ rm _build/default/output/a $ dune build contents - bash output running - bash contents running Check that Dune clears stale files from directory targets. @@ -365,9 +355,7 @@ Check that Dune clears stale files from directory targets. > EOF $ dune build contents - bash output running - bash contents running Note that the stale "output/a" file got removed. diff --git a/test/blackbox-tests/test-cases/display.t b/test/blackbox-tests/test-cases/display.t index a5c41d1a57fb..92eac3f75e72 100644 --- a/test/blackbox-tests/test-cases/display.t +++ b/test/blackbox-tests/test-cases/display.t @@ -18,12 +18,12 @@ Errors with location embed in their output [1] $ dune clean; dune build --always-show-command-line - sh alias default (exit 42) (cd _build/default && SH -c 'echo '\''File "foo", line 1: blah'\''; exit 42') File "foo", line 1: blah [1] $ dune clean; dune build --display short + sh alias default (exit 42) File "foo", line 1: blah [1] @@ -47,8 +47,6 @@ Errors without location embed in their output 1 | (rule 2 | (alias default) 3 | (action (system "echo failure; exit 42"))) - sh alias default (exit 42) - (cd _build/default && SH -c 'echo failure; exit 42') failure [1] @@ -57,7 +55,6 @@ Errors without location embed in their output 1 | (rule 2 | (alias default) 3 | (action (system "echo failure; exit 42"))) - sh alias default (exit 42) (cd _build/default && SH -c 'echo failure; exit 42') failure [1] @@ -68,7 +65,6 @@ Errors without location embed in their output 2 | (alias default) 3 | (action (system "echo failure; exit 42"))) sh alias default (exit 42) - (cd _build/default && SH -c 'echo failure; exit 42') failure [1] @@ -96,8 +92,7 @@ Errors with no output 1 | (rule 2 | (alias default) 3 | (action (system "exit 42"))) - sh alias default (exit 42) - (cd _build/default && SH -c 'exit 42') + Command exited with code 42. [1] $ dune clean; dune build --always-show-command-line @@ -105,8 +100,8 @@ Errors with no output 1 | (rule 2 | (alias default) 3 | (action (system "exit 42"))) - sh alias default (exit 42) (cd _build/default && SH -c 'exit 42') + Command exited with code 42. [1] $ dune clean; dune build --display short @@ -115,7 +110,6 @@ Errors with no output 2 | (alias default) 3 | (action (system "exit 42"))) sh alias default (exit 42) - (cd _build/default && SH -c 'exit 42') [1] $ dune clean; dune build --display short --always-show-command-line @@ -137,11 +131,10 @@ Successful commands with output > EOF $ dune clean; dune build - sh alias default Hello, world! $ dune clean; dune build --always-show-command-line - sh alias default + (cd _build/default && SH -c 'echo '\''Hello, world!'\''') Hello, world! $ dune clean; dune build --display short @@ -150,4 +143,5 @@ Successful commands with output $ dune clean; dune build --display short --always-show-command-line sh alias default + (cd _build/default && SH -c 'echo '\''Hello, world!'\''') Hello, world! diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t index 3fb8c67399c0..16d11e951a70 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t @@ -109,18 +109,14 @@ Test that the cache stores all historical build results. > EOF $ cp dune-v1 dune $ dune build --config-file=config t2 - bash t1 running - bash t2 running $ cat _build/default/t2 v1 v1 $ cp dune-v2 dune $ dune build --config-file=config t2 - bash t1 running - bash t2 running $ cat _build/default/t2 v2 diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t index a96e12640a19..b11563e45db2 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t @@ -108,18 +108,14 @@ Test that the cache stores all historical build results. > EOF $ cp dune-v1 dune $ dune build --config-file=config t2 - bash t1 running - bash t2 running $ cat _build/default/t2 v1 v1 $ cp dune-v2 dune $ dune build --config-file=config t2 - bash t1 running - bash t2 running $ cat _build/default/t2 v2 diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/run.t b/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/run.t index 4386ac2ac2dc..2eb0b77d27d0 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/run.t +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system.t/run.t @@ -67,7 +67,6 @@ Test the argument syntax $ dune build --root driver-tests test_ppx_args.cma Entering directory 'driver-tests' - ppx test_ppx_args.pp.ml .ppx/454728df5270ab91f8a5af6b5e860eb0/ppx.exe -arg1 -arg2 @@ -97,7 +96,6 @@ Test that going through the -ppx option of the compiler works $ dune build --root driver-tests test_ppx_staged.cma Entering directory 'driver-tests' - ocamlc .test_ppx_staged.objs/byte/test_ppx_staged.{cmi,cmo,cmt} tool name: ocamlc args:--as-ppx -arg1 -arg2 -arg3=Oreo -foo bar Snickerdoodle --cookie france="Petit Beurre" --cookie italy="Biscotti" --cookie library-name="test_ppx_staged" @@ -107,7 +105,6 @@ Test using installed drivers Entering directory 'driver' $ OCAMLPATH=driver/_build/install/default/lib dune build --root use-external-driver driveruser.cma Entering directory 'use-external-driver' - ppx driveruser.pp.ml .ppx/35d69311d5da258d073875db2b34f33b/ppx.exe -arg1 -arg2 @@ -129,7 +126,6 @@ Test using installed drivers $ OCAMLPATH=driver/_build/install/default/lib dune build --root replaces driveruser.cma Entering directory 'replaces' - ppx driveruser.pp.ml replacesdriver .ppx/886937db0da323b743b4366c6d3a795f/ppx.exe -arg1 @@ -154,7 +150,6 @@ Test using installed drivers Entering directory 'driver-replaces' $ OCAMLPATH=driver/_build/install/default/lib:driver-replaces/_build/install/default/lib dune build --root replaces-external driveruser.cma Entering directory 'replaces-external' - ppx driveruser.pp.ml replacesdriver .ppx/886937db0da323b743b4366c6d3a795f/ppx.exe -arg1 diff --git a/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t b/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t index d50af8c202b0..e34f9c68f879 100644 --- a/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t +++ b/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t @@ -1,7 +1,6 @@ %{exe:foo.exe} should not be veisible if foo.exe is added to PATH via the binaries stanza. %{bin:foo} is visible on the other hand. $ dune build - foo alias default this is foo.exe Error: No rule found for foo.exe -> required by %{exe:foo.exe} at dune:7 diff --git a/test/blackbox-tests/test-cases/env/env-bins.t/run.t b/test/blackbox-tests/test-cases/env/env-bins.t/run.t index 607188f03652..ab5a5e2c7ca8 100644 --- a/test/blackbox-tests/test-cases/env/env-bins.t/run.t +++ b/test/blackbox-tests/test-cases/env/env-bins.t/run.t @@ -1,12 +1,10 @@ Basic test that we can use private binaries as public ones $ dune build --root private-bin-import Entering directory 'private-bin-import' - priv alias using-priv/runtest Executing priv as priv PATH: $TESTCASE_ROOT/private-bin-import/_build/default/using-priv/.bin $TESTCASE_ROOT/private-bin-import/_build/install/default/bin - priv-renamed alias using-priv/runtest Executing priv as priv-renamed PATH: $TESTCASE_ROOT/private-bin-import/_build/default/using-priv/.bin @@ -15,27 +13,22 @@ Basic test that we can use private binaries as public ones Override public binary in env $ dune build --root override-bins Entering directory 'override-bins' - foo alias test/runtest private binary - foo alias default public binary Nest env binaries $ dune build --root nested-env Entering directory 'nested-env' - priv alias using-priv/nested/runtest Executing priv as priv PATH: $TESTCASE_ROOT/nested-env/_build/default/using-priv/nested/.bin $TESTCASE_ROOT/nested-env/_build/default/using-priv/.bin $TESTCASE_ROOT/nested-env/_build/install/default/bin - priv-renamed alias using-priv/nested/runtest Executing priv as priv-renamed PATH: $TESTCASE_ROOT/nested-env/_build/default/using-priv/nested/.bin $TESTCASE_ROOT/nested-env/_build/default/using-priv/.bin $TESTCASE_ROOT/nested-env/_build/install/default/bin - priv-renamed-nested alias using-priv/nested/runtest Executing priv as priv-renamed-nested PATH: $TESTCASE_ROOT/nested-env/_build/default/using-priv/nested/.bin diff --git a/test/blackbox-tests/test-cases/env/env-dune-file.t/flag-field/dune b/test/blackbox-tests/test-cases/env/env-dune-file.t/flag-field/dune index af857405486b..fbbd9d16f906 100644 --- a/test/blackbox-tests/test-cases/env/env-dune-file.t/flag-field/dune +++ b/test/blackbox-tests/test-cases/env/env-dune-file.t/flag-field/dune @@ -11,5 +11,5 @@ (name default) (action (progn - (echo "var visible from dune: %{env:DUNE_FOO=absent}") - (run ./foo.exe)))) \ No newline at end of file + (echo "var visible from dune: %{env:DUNE_FOO=absent}\n") + (run ./foo.exe)))) diff --git a/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t b/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t index d68dc44efe8e..1a903d3c64bf 100644 --- a/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t +++ b/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t @@ -6,14 +6,12 @@ env vars set in env should be visible to all subdirs env vars interpreted in various fields, such as flags $ dune build --force --root flag-field Entering directory 'flag-field' - var visible from dune: -principal foo alias default - DUNE_FOO: -principal + var visible from dune: -principalDUNE_FOO: -principal global vars are overridden $ DUNE_FOO=blarg dune build --force --root flag-field Entering directory 'flag-field' - var visible from dune: -principal foo alias default - DUNE_FOO: -principal + var visible from dune: -principalDUNE_FOO: -principal proper inheritance chain of env stanzas $ dune build --root inheritance diff --git a/test/blackbox-tests/test-cases/env/env-tracking.t/run.t b/test/blackbox-tests/test-cases/env/env-tracking.t/run.t index d394ebbca5c0..e4dad216f2c5 100644 --- a/test/blackbox-tests/test-cases/env/env-tracking.t/run.t +++ b/test/blackbox-tests/test-cases/env/env-tracking.t/run.t @@ -2,7 +2,6 @@ Aliases without a (env) dependency are not rebuilt when the environment changes: $ dune build @without_dep - a alias without_dep X is not set Y is not set $ X=x dune build @without_dep @@ -10,11 +9,9 @@ changes: But if there is a dependency, the alias gets rebuilt: $ dune build @with_dep - a alias with_dep X is not set Y is not set $ X=x dune build @with_dep - a alias with_dep X = "x" Y is not set diff --git a/test/blackbox-tests/test-cases/exe-name-mangle.t/run.t b/test/blackbox-tests/test-cases/exe-name-mangle.t/run.t index 56685fd8b962..a45eabba2b3b 100644 --- a/test/blackbox-tests/test-cases/exe-name-mangle.t/run.t +++ b/test/blackbox-tests/test-cases/exe-name-mangle.t/run.t @@ -5,7 +5,6 @@ Single module case. Here we technically don't need an alias module $ dune build --root single-module Entering directory 'single-module' - exe alias default this module is unlinkable this module is unlinkable @@ -13,7 +12,6 @@ The multi module case always requires an alias. $ dune build --root multi-module Entering directory 'multi-module' - baz alias default not directly usable Multiple executables defined in the same directory diff --git a/test/blackbox-tests/test-cases/force-test.t/run.t b/test/blackbox-tests/test-cases/force-test.t/run.t index a7c141a839e4..e06920516c04 100644 --- a/test/blackbox-tests/test-cases/force-test.t/run.t +++ b/test/blackbox-tests/test-cases/force-test.t/run.t @@ -1,11 +1,9 @@ Running a test and then forcing a re-run will only re-run the test exe: $ dune runtest - f alias runtest Foo Bar $ dune runtest Note that nothing is rebuilt, only the binary is executed again: $ dune runtest --force - f alias runtest Foo Bar diff --git a/test/blackbox-tests/test-cases/github1616.t/run.t b/test/blackbox-tests/test-cases/github1616.t/run.t index f6aa4dfef29a..4cea9ff4f1e8 100644 --- a/test/blackbox-tests/test-cases/github1616.t/run.t +++ b/test/blackbox-tests/test-cases/github1616.t/run.t @@ -2,5 +2,4 @@ Regression test for #1616 $ env PATH="$PWD/bin2:$PWD/bin1:$PATH" dune build --root root Entering directory 'root' - prog alias default Hello, World! diff --git a/test/blackbox-tests/test-cases/github2228.t/run.t b/test/blackbox-tests/test-cases/github2228.t/run.t index 7c78301971a9..e4f0edb083a5 100644 --- a/test/blackbox-tests/test-cases/github2228.t/run.t +++ b/test/blackbox-tests/test-cases/github2228.t/run.t @@ -3,7 +3,6 @@ would fail because the .cmi wasn't correctly copied to the _build/install dir. $ dune build @install $ dune runtest - test alias test/runtest testing $ dune install --prefix ./installed 2>&1 | grep -i cmi Installing installed/lib/foobar/foobar.cmi diff --git a/test/blackbox-tests/test-cases/github3490.t/run.t b/test/blackbox-tests/test-cases/github3490.t/run.t index 37ba4564fab6..128bb7d0f44a 100644 --- a/test/blackbox-tests/test-cases/github3490.t/run.t +++ b/test/blackbox-tests/test-cases/github3490.t/run.t @@ -22,4 +22,3 @@ the test suite; but we do not need to print it so we can grep it out $ dune runtest --diff-command 'diff -u' 2>&1 | grep -v + | grep -v diff | grep -v "^--- test" File "test", line 1, characters 0-0: - sh (internal) (exit 1) diff --git a/test/blackbox-tests/test-cases/github568.t/run.t b/test/blackbox-tests/test-cases/github568.t/run.t index ce3bc22c940e..c5d723475910 100644 --- a/test/blackbox-tests/test-cases/github568.t/run.t +++ b/test/blackbox-tests/test-cases/github568.t/run.t @@ -1,3 +1,3 @@ $ dune runtest -p lib1 --debug-dependency-path - test1 alias runtest + (cd _build/default && ./test1.exe) running test 1 diff --git a/test/blackbox-tests/test-cases/github660.t/run.t b/test/blackbox-tests/test-cases/github660.t/run.t index ef75ae81bb19..81ce3c36b198 100644 --- a/test/blackbox-tests/test-cases/github660.t/run.t +++ b/test/blackbox-tests/test-cases/github660.t/run.t @@ -5,12 +5,10 @@ When there are explicit interfaces, modules must be rebuilt. $ dune runtest --root explicit-interfaces Entering directory 'explicit-interfaces' - main alias runtest hello $ echo 'let _x = 1' >> explicit-interfaces/lib_sub.ml $ dune runtest --root explicit-interfaces Entering directory 'explicit-interfaces' - main alias runtest hello When there are no interfaces, the situation is the same, but it is not possible @@ -18,10 +16,8 @@ to rely on these. $ dune runtest --root no-interfaces Entering directory 'no-interfaces' - main alias runtest hello $ echo 'let _x = 1' >> no-interfaces/lib_sub.ml $ dune runtest --root no-interfaces Entering directory 'no-interfaces' - main alias runtest hello diff --git a/test/blackbox-tests/test-cases/glob_files_rec.t/run.t b/test/blackbox-tests/test-cases/glob_files_rec.t/run.t index af9f27693087..3cbd1408a165 100644 --- a/test/blackbox-tests/test-cases/glob_files_rec.t/run.t +++ b/test/blackbox-tests/test-cases/glob_files_rec.t/run.t @@ -25,7 +25,6 @@ Leave a/b2/c empty to make sure we don't choke on empty dirs. $ touch foo/a/b3/x.other $ dune build @x - bash alias x foo/a/b1/c/x.txt foo/a/b1/c/y.txt foo/a/b3/x.txt @@ -35,7 +34,7 @@ Leave a/b2/c empty to make sure we don't choke on empty dirs. $ find . -name \*.txt | dune_cmd count-lines 10 $ dune build @x --force 2>&1 | dune_cmd count-lines - 6 + 5 Check that generated files are taken into account ------------------------------------------------- diff --git a/test/blackbox-tests/test-cases/inline_tests-multi-mode.t/run.t b/test/blackbox-tests/test-cases/inline_tests-multi-mode.t/run.t index 8d88a58cab3a..584ab0b7038e 100644 --- a/test/blackbox-tests/test-cases/inline_tests-multi-mode.t/run.t +++ b/test/blackbox-tests/test-cases/inline_tests-multi-mode.t/run.t @@ -29,7 +29,5 @@ Reproduction case for #3347 $ touch test.ml $ dune runtest - inline_test_runner_test alias runtest Test byte - inline_test_runner_test alias runtest Test native diff --git a/test/blackbox-tests/test-cases/inline_tests/dune-file.t/run.t b/test/blackbox-tests/test-cases/inline_tests/dune-file.t/run.t index 78738c464292..1baaf505cfc5 100644 --- a/test/blackbox-tests/test-cases/inline_tests/dune-file.t/run.t +++ b/test/blackbox-tests/test-cases/inline_tests/dune-file.t/run.t @@ -4,7 +4,6 @@ externally installed. First we build and use the backend locally: $ dune runtest dune-file - inline_test_runner_foo_tests alias dune-file/runtest 414243 Then we install the backend and check that the "inline_tests.backend" @@ -28,5 +27,4 @@ package: $ export OCAMLPATH=$PWD/_install/lib; dune runtest --root dune-file-user Entering directory 'dune-file-user' - inline_test_runner_foo_tests alias runtest 414243 diff --git a/test/blackbox-tests/test-cases/inline_tests/executable-flags.t/run.t b/test/blackbox-tests/test-cases/inline_tests/executable-flags.t/run.t index 29e9929d9570..6a14023cf24b 100644 --- a/test/blackbox-tests/test-cases/inline_tests/executable-flags.t/run.t +++ b/test/blackbox-tests/test-cases/inline_tests/executable-flags.t/run.t @@ -6,7 +6,6 @@ to be successful. $ dune runtest valid_options --root ./test-project Entering directory 'test-project' - inline_test_runner_valid_option_test alias valid_options/runtest backend_foo Lastly, we pass an invalid option to flags field expecting compilation diff --git a/test/blackbox-tests/test-cases/inline_tests/many-backends-choose.t/run.t b/test/blackbox-tests/test-cases/inline_tests/many-backends-choose.t/run.t index 55608b221ec8..205490bfe02d 100644 --- a/test/blackbox-tests/test-cases/inline_tests/many-backends-choose.t/run.t +++ b/test/blackbox-tests/test-cases/inline_tests/many-backends-choose.t/run.t @@ -21,5 +21,4 @@ > EOF $ dune runtest - inline_test_runner_foo_mbc alias runtest backend_mbc1 diff --git a/test/blackbox-tests/test-cases/inline_tests/multiple-inline-tests.t/run.t b/test/blackbox-tests/test-cases/inline_tests/multiple-inline-tests.t/run.t index 53669cea8818..7a2e3f9c32af 100644 --- a/test/blackbox-tests/test-cases/inline_tests/multiple-inline-tests.t/run.t +++ b/test/blackbox-tests/test-cases/inline_tests/multiple-inline-tests.t/run.t @@ -27,7 +27,5 @@ Create a dummy backend and two libraries with inline_tests try to run them: $ env -u OCAMLRUNPARAM dune runtest - inline_test_runner_foo_simple1 alias runtest test - inline_test_runner_foo_simple2 alias runtest test diff --git a/test/blackbox-tests/test-cases/inline_tests/simple.t/run.t b/test/blackbox-tests/test-cases/inline_tests/simple.t/run.t index e69524ca8f06..33cafda4230d 100644 --- a/test/blackbox-tests/test-cases/inline_tests/simple.t/run.t +++ b/test/blackbox-tests/test-cases/inline_tests/simple.t/run.t @@ -27,8 +27,6 @@ File "dune", line 9, characters 1-40: 9 | (inline_tests (backend backend_simple))) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - inline_test_runner_foo_simple alias runtest (exit 2) - (cd _build/default && .foo_simple.inline-tests/inline_test_runner_foo_simple.exe) Fatal error: exception File ".foo_simple.inline-tests/inline_test_runner_foo_simple.ml-gen", line 1, characters 40-46: Assertion failed [1] @@ -43,7 +41,5 @@ The expected behavior for the following three tests is to output nothing: the te File "dune", line 9, characters 1-40: 9 | (inline_tests (backend backend_simple))) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - inline_test_runner_foo_simple alias runtest (exit 2) - (cd _build/default && .foo_simple.inline-tests/inline_test_runner_foo_simple.exe) Fatal error: exception File ".foo_simple.inline-tests/inline_test_runner_foo_simple.ml-gen", line 1, characters 40-46: Assertion failed [1] diff --git a/test/blackbox-tests/test-cases/jsoo/inline-tests.t/run.t b/test/blackbox-tests/test-cases/jsoo/inline-tests.t/run.t index 8a73f932e9c2..1b2d70bab0b2 100644 --- a/test/blackbox-tests/test-cases/jsoo/inline-tests.t/run.t +++ b/test/blackbox-tests/test-cases/jsoo/inline-tests.t/run.t @@ -5,12 +5,9 @@ Run inline tests using node js > EOF $ dune runtest - inline_test_runner_inline_tests_byte alias byte/runtest inline tests (Byte) inline tests (Byte) - node alias js/runtest inline tests (JS) inline tests (JS) - inline_test_runner_inline_tests_native alias native/runtest inline tests (Native) inline tests (Native) diff --git a/test/blackbox-tests/test-cases/multi-dir.t/run.t b/test/blackbox-tests/test-cases/multi-dir.t/run.t index 58167b7c3f43..5a80e33d1bd2 100644 --- a/test/blackbox-tests/test-cases/multi-dir.t/run.t +++ b/test/blackbox-tests/test-cases/multi-dir.t/run.t @@ -3,7 +3,6 @@ Simple test with a multi dir exe $ dune build --root test1 Entering directory 'test1' - foo alias default Hello, world! Test that include_subdirs stop the recursion @@ -11,7 +10,6 @@ Test that include_subdirs stop the recursion $ dune build --root test2 Entering directory 'test2' - main alias default Hello, world! Test with C stubs in sub-directories diff --git a/test/blackbox-tests/test-cases/odoc/warnings.t/run.t b/test/blackbox-tests/test-cases/odoc/warnings.t/run.t index 867142706dde..e35b4be11961 100644 --- a/test/blackbox-tests/test-cases/odoc/warnings.t/run.t +++ b/test/blackbox-tests/test-cases/odoc/warnings.t/run.t @@ -25,9 +25,9 @@ These packages are in a nested env, the option is disabled, should success with In release mode, no error: $ dune build -p foo_doc,foo_lib @doc - odoc _doc/_odoc/pkg/foo_doc/page-foo.odoc + (cd _build/default/_doc/_odoc/pkg/foo_doc && /home/dim/.opam/4.12.0/bin/odoc compile --pkg foo_doc -o page-foo.odoc ../../../../foo_doc/foo.mld) File "../../../../foo_doc/foo.mld", line 4, characters 0-0: End of text is not allowed in '[...]' (code). - odoc foo_lib/.foo.objs/byte/foo.odoc + (cd _build/default/foo_lib/.foo.objs/byte && /home/dim/.opam/4.12.0/bin/odoc compile -I . -I ../../../_doc/_odoc/pkg/foo_lib --pkg foo_lib -o foo.odoc foo.cmti) File "foo_lib/foo.mli", line 1, characters 7-7: End of text is not allowed in '[...]' (code). diff --git a/test/blackbox-tests/test-cases/output-obj.t/run.t b/test/blackbox-tests/test-cases/output-obj.t/run.t index b05b3a2f0e30..ae201838071a 100644 --- a/test/blackbox-tests/test-cases/output-obj.t/run.t +++ b/test/blackbox-tests/test-cases/output-obj.t/run.t @@ -1,12 +1,8 @@ $ dune build @all $ dune build @runtest 2>&1 | dune_cmd sanitize - static alias runtest OK: ./static.exe - static alias runtest OK: ./static.bc - dynamic alias runtest OK: ./dynamic.exe ./test.bc$ext_dll - dynamic alias runtest OK: ./dynamic.exe ./test$ext_dll # static alias runtest # OK: ./static.bc.c.exe diff --git a/test/blackbox-tests/test-cases/package-dep.t/run.t b/test/blackbox-tests/test-cases/package-dep.t/run.t index c5de0f019bde..a9d661e4af55 100644 --- a/test/blackbox-tests/test-cases/package-dep.t/run.t +++ b/test/blackbox-tests/test-cases/package-dep.t/run.t @@ -1,3 +1,2 @@ $ dune runtest - test alias runtest 42 42 diff --git a/test/blackbox-tests/test-cases/path-rewriting.t b/test/blackbox-tests/test-cases/path-rewriting.t index a1d109669df3..145d82a4f283 100644 --- a/test/blackbox-tests/test-cases/path-rewriting.t +++ b/test/blackbox-tests/test-cases/path-rewriting.t @@ -9,12 +9,10 @@ rewrite the current working directory: > EOF $ dune build - sh x /workspace_root It works with sandboxing as well: $ dune clean $ dune build --sandbox copy - sh x /workspace_root diff --git a/test/blackbox-tests/test-cases/pipe-actions.t/run.t b/test/blackbox-tests/test-cases/pipe-actions.t/run.t index 01c654de110e..a9e3415925e9 100644 --- a/test/blackbox-tests/test-cases/pipe-actions.t/run.t +++ b/test/blackbox-tests/test-cases/pipe-actions.t/run.t @@ -33,7 +33,6 @@ You need to set the language to 2.7 or higher for it to work: > EOF $ dune build @pipe - tr alias pipe x y z diff --git a/test/blackbox-tests/test-cases/ppx-rewriter.t/run.t b/test/blackbox-tests/test-cases/ppx-rewriter.t/run.t index c3ba0dac7de5..3c3379bc6c92 100644 --- a/test/blackbox-tests/test-cases/ppx-rewriter.t/run.t +++ b/test/blackbox-tests/test-cases/ppx-rewriter.t/run.t @@ -1,5 +1,4 @@ $ dune build ./w_omp_driver.exe - ppx w_omp_driver.pp.ml -arg: omp This test is broken because ppx_driver doesn't support migrate custom arguments diff --git a/test/blackbox-tests/test-cases/private-modules.t/run.t b/test/blackbox-tests/test-cases/private-modules.t/run.t index 320bd992a7d1..c4f4cf95151b 100644 --- a/test/blackbox-tests/test-cases/private-modules.t/run.t +++ b/test/blackbox-tests/test-cases/private-modules.t/run.t @@ -1,6 +1,5 @@ $ dune build --root accessible-via-public Entering directory 'accessible-via-public' - runfoo alias default private module bar $ dune build --root inaccessible-in-deps 2>&1 diff --git a/test/blackbox-tests/test-cases/quoting.t/run.t b/test/blackbox-tests/test-cases/quoting.t/run.t index 6ba821d30a27..bfa53dfb0e89 100644 --- a/test/blackbox-tests/test-cases/quoting.t/run.t +++ b/test/blackbox-tests/test-cases/quoting.t/run.t @@ -25,7 +25,6 @@ The targets should only be interpreted as a single path when quoted $ dune runtest --root quote-from-context Entering directory 'quote-from-context' - count_args alias runtest Number of args: 3 $ dune runtest --root quotes-multi diff --git a/test/blackbox-tests/test-cases/reason.t/run.t b/test/blackbox-tests/test-cases/reason.t/run.t index dcff46d29165..5cdd11a847f9 100644 --- a/test/blackbox-tests/test-cases/reason.t/run.t +++ b/test/blackbox-tests/test-cases/reason.t/run.t @@ -3,7 +3,6 @@ Tests for reason Build and run a reason binary: $ dune build @runtest - rbin alias runtest Cppome hello world Bar diff --git a/test/blackbox-tests/test-cases/report-all-errors.t b/test/blackbox-tests/test-cases/report-all-errors.t index 09262d4986e4..a72c67d14de9 100644 --- a/test/blackbox-tests/test-cases/report-all-errors.t +++ b/test/blackbox-tests/test-cases/report-all-errors.t @@ -52,11 +52,9 @@ failing before it had a chance to start thinking about building `z`. File "dune", line 10, characters 0-42: 10 | (rule (with-stdout-to y (run ./fail.exe))) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - fail y (exit 1) - (cd _build/default && ./fail.exe) > _build/default/y + Command exited with code 1. File "dune", line 11, characters 0-42: 11 | (rule (with-stdout-to z (run ./fail.exe))) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - fail z (exit 1) - (cd _build/default && ./fail.exe) > _build/default/z + Command exited with code 1. [1] diff --git a/test/blackbox-tests/test-cases/select.t/run.t b/test/blackbox-tests/test-cases/select.t/run.t index 2e4d41c6ec0b..1dcec08f058a 100644 --- a/test/blackbox-tests/test-cases/select.t/run.t +++ b/test/blackbox-tests/test-cases/select.t/run.t @@ -15,7 +15,6 @@ > EOF $ dune runtest - main alias runtest bar has unix foo has no fake @@ -36,6 +35,5 @@ > EOF $ dune runtest - main alias runtest bar has unix foo has no fake diff --git a/test/blackbox-tests/test-cases/tests-stanza-action.t/run.t b/test/blackbox-tests/test-cases/tests-stanza-action.t/run.t index 5c7064021e96..81f796857ea7 100644 --- a/test/blackbox-tests/test-cases/tests-stanza-action.t/run.t +++ b/test/blackbox-tests/test-cases/tests-stanza-action.t/run.t @@ -2,7 +2,6 @@ If there is an (action) field, it is used to invoke to the executable (in both regular and expect modes: $ dune build @explicit-regular/runtest - my_test alias explicit-regular/runtest argv[0] = "./my_test.exe" argv[1] = "arg1" argv[2] = "arg2" @@ -13,5 +12,4 @@ regular and expect modes: If there is no field, the program is run with no arguments: $ dune build @default/runtest - my_test alias default/runtest argv[0] = "./my_test.exe" diff --git a/test/blackbox-tests/test-cases/tests-stanza.t/run.t b/test/blackbox-tests/test-cases/tests-stanza.t/run.t index 0963498047a3..1aca6b9ae079 100644 --- a/test/blackbox-tests/test-cases/tests-stanza.t/run.t +++ b/test/blackbox-tests/test-cases/tests-stanza.t/run.t @@ -1,13 +1,10 @@ $ dune runtest --root singular Entering directory 'singular' - singular alias runtest singular test $ dune runtest --root plural Entering directory 'plural' - regular_test alias runtest regular test - regular_test2 alias runtest regular test2 $ dune runtest --root generated Entering directory 'generated' diff --git a/test/blackbox-tests/test-cases/vendor/main.t/run.t b/test/blackbox-tests/test-cases/vendor/main.t/run.t index eadfc0ab1beb..7f200f9fc6b5 100644 --- a/test/blackbox-tests/test-cases/vendor/main.t/run.t +++ b/test/blackbox-tests/test-cases/vendor/main.t/run.t @@ -7,7 +7,6 @@ Aliases should not be resolved in vendored sub directories $ dune runtest --root duniverse Entering directory 'duniverse' - test alias tests/runtest Hello from main lib! When compiling vendored code, all warnings should be disabled diff --git a/test/blackbox-tests/test-cases/virtual-libraries/impl-private-modules.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/impl-private-modules.t/run.t index 38e22f51c77f..509a4e409b60 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/impl-private-modules.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/impl-private-modules.t/run.t @@ -1,5 +1,4 @@ They can only introduce private modules: $ dune build --debug-dependency-path - test alias default Private module Baz implementing bar diff --git a/test/blackbox-tests/test-cases/virtual-libraries/impl-using-vlib-modules.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/impl-using-vlib-modules.t/run.t index b6d31676d32b..1a8bce72a4f0 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/impl-using-vlib-modules.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/impl-using-vlib-modules.t/run.t @@ -1,5 +1,4 @@ Implementations may refer to virtual library's modules $ dune build - test alias default bar from vlib Foo.run implemented diff --git a/test/blackbox-tests/test-cases/virtual-libraries/implements-external.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/implements-external.t/run.t index b8fc8ba8cd2e..2dd6df3e2d01 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/implements-external.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/implements-external.t/run.t @@ -7,25 +7,21 @@ First we create an external library Then we make sure that we can implement it $ env OCAMLPATH=vlib/_build/install/default/lib dune build --root impl --debug-dependency-path Entering directory 'impl' - test alias default bar from vlib Foo.run implemented Make sure that we can also implement native only variants $ env OCAMLPATH=vlib/_build/install/default/lib dune build --root impl-native-only --debug-dependency-path Entering directory 'impl-native-only' - run alias default implement virtual module We can implement external variants with mli only modules $ env OCAMLPATH=vlib/_build/install/default/lib dune build --root impl-intf-only --debug-dependency-path Entering directory 'impl-intf-only' - run alias default implemented mli only magic number: 42 Implement external virtual libraries with private modules $ env OCAMLPATH=vlib/_build/install/default/lib dune build --root impl-private-module --debug-dependency-path Entering directory 'impl-private-module' - run alias default Name: implement virtual module. Magic number: 42 diff --git a/test/blackbox-tests/test-cases/virtual-libraries/preprocess.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/preprocess.t/run.t index 7e5417155808..1a7acaf3de15 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/preprocess.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/preprocess.t/run.t @@ -1,4 +1,3 @@ Virtual libraries and preprocessed source $ dune build - test alias default foo diff --git a/test/blackbox-tests/test-cases/virtual-libraries/private-modules-overlapping-names.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/private-modules-overlapping-names.t/run.t index 961b59f3df95..e245d26d9735 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/private-modules-overlapping-names.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/private-modules-overlapping-names.t/run.t @@ -1,6 +1,5 @@ Implementations may have private modules that have overlapping names with the virtual lib $ dune build - foo alias default impl's own Priv.run implementation of foo diff --git a/test/blackbox-tests/test-cases/virtual-libraries/unwrapped.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/unwrapped.t/run.t index 283eee6b2a36..7d43165737e6 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/unwrapped.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/unwrapped.t/run.t @@ -1,6 +1,5 @@ Unwrapped virtual library $ dune build - foo alias default Running from vlib_more running implementation @@ -9,6 +8,5 @@ Unwrapped virtual library Entering directory 'vlib' $ env OCAMLPATH=vlib/_build/install/default/lib dune build --root impl --debug-dependency-path Entering directory 'impl' - foo alias default Running from vlib_more running implementation diff --git a/test/blackbox-tests/test-cases/virtual-libraries/variants-simple.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/variants-simple.t/run.t index fd0d65469b06..e33f0edd3aa4 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/variants-simple.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/variants-simple.t/run.t @@ -1,4 +1,3 @@ Virtual library with a single module $ dune build - foo alias default running implementation diff --git a/test/blackbox-tests/test-cases/virtual-libraries/variants-sub-module.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/variants-sub-module.t/run.t index 1bbc086996f2..923f5a629359 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/variants-sub-module.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/variants-sub-module.t/run.t @@ -1,4 +1,3 @@ Virtual library where a wrapped module is virtual $ dune build - run alias default Impl's Vmd.run () diff --git a/test/blackbox-tests/test-cases/virtual-libraries/vlib-default-impl.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/vlib-default-impl.t/run.t index 5decc4e76526..4f380d807537 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/vlib-default-impl.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/vlib-default-impl.t/run.t @@ -11,7 +11,6 @@ in an appropriate error message. Basic sample selecting implementation according to default library. $ dune build --root default-impl Entering directory 'default-impl' - bar alias default hi from lib.default Check that default implementation data is installed in the dune package file. @@ -106,5 +105,4 @@ First we create an external library and implementation Then we make sure that it works fine. $ env OCAMLPATH=external/lib/_build/install/default/lib dune build --root external/exe --debug-dependency-path Entering directory 'external/exe' - bar alias default hey diff --git a/test/blackbox-tests/test-cases/with-exit-codes.t/run.t b/test/blackbox-tests/test-cases/with-exit-codes.t/run.t index 34d0f23b1bc5..74a64d5bd171 100644 --- a/test/blackbox-tests/test-cases/with-exit-codes.t/run.t +++ b/test/blackbox-tests/test-cases/with-exit-codes.t/run.t @@ -25,7 +25,6 @@ 6 | (alias a) 7 | (action (with-accepted-exit-codes 0 (run ./exit.exe 1)))) exit alias a (exit 1) - (cd _build/default && ./exit.exe 1) [1] $ cat >> dune <> dune < _build/default/out2.txt [1] $ cat >> dune < Date: Tue, 2 Nov 2021 14:55:43 +0000 Subject: [PATCH 18/32] Update tests Signed-off-by: Jeremie Dimino --- test/blackbox-tests/test-cases/env/env-dune-file.t/run.t | 6 ++++-- test/blackbox-tests/test-cases/patch-back-source-tree.t | 2 -- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t b/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t index 1a903d3c64bf..a2fcee0a02e8 100644 --- a/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t +++ b/test/blackbox-tests/test-cases/env/env-dune-file.t/run.t @@ -6,12 +6,14 @@ env vars set in env should be visible to all subdirs env vars interpreted in various fields, such as flags $ dune build --force --root flag-field Entering directory 'flag-field' - var visible from dune: -principalDUNE_FOO: -principal + var visible from dune: -principal + DUNE_FOO: -principal global vars are overridden $ DUNE_FOO=blarg dune build --force --root flag-field Entering directory 'flag-field' - var visible from dune: -principalDUNE_FOO: -principal + var visible from dune: -principal + DUNE_FOO: -principal proper inheritance chain of env stanzas $ dune build --root inheritance 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 921f0ec190dc..80aeef5680c2 100644 --- a/test/blackbox-tests/test-cases/patch-back-source-tree.t +++ b/test/blackbox-tests/test-cases/patch-back-source-tree.t @@ -76,7 +76,6 @@ Non-modified dependencies are not promoted > EOF $ dune build - sh alias default Hello, world! $ if ! test -f x; then echo ok; fi ok @@ -176,7 +175,6 @@ If a source file is read-only, the action sees it as writable: non-writable $ dune build - sh alias default writable And as the action modified `x`, its permissions have now changed From daab81f07a091b81692acde805ff3597c6d98900 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 24 Oct 2021 18:47:40 -0600 Subject: [PATCH 19/32] fix: better cycle detection for virtual libraries An implementation of a virtual library must always depend on the virtual library directly and not through a dependency. This is becaue the implementation + vlib form a single archive during linking. Signed-off-by: Rudi Grinberg ps-id: BF2B3D35-1494-48B4-90F2-60647E2C1DD5 --- CHANGES.md | 3 + src/dune_rules/lib.ml | 79 +++++++++++++++---- .../virtual-libraries/github2896.t/run.t | 15 +++- 3 files changed, 78 insertions(+), 19 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index f415da4073d9..7ccc33c6a20f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,9 @@ Unreleased ---------- +- Report cycles between virtual libraries and their implementation (#5050, + fixes #2896, @rgrinberg) + - Allow users to specify dynamic dependencies in rules. For example `(deps %{read:foo.gen})` (#4662, fixes #4089, @jeremiedimino) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 78f5700c229d..90b43992ad56 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -187,6 +187,16 @@ module Error = struct ] , [] ) + let vlib_in_closure ~loc ~impl ~vlib = + let impl = Lib_info.name impl in + let vlib = Lib_info.name vlib in + User_error.make ~loc + [ Pp.textf + "Virtual library %S is used by a dependency of %S. This is not \ + allowed." + (Lib_name.to_string vlib) (Lib_name.to_string impl) + ] + let only_ppx_deps_allowed ~loc dep = let name = Lib_info.name dep in make ~loc @@ -312,6 +322,9 @@ module T = struct ; sub_systems : Sub_system0.Instance.t Memo.Lazy.t Sub_system_name.Map.t ; modules : Modules.t Memo.Lazy.t option ; src_dirs : Path.Set.t Memo.Lazy.t + ; (* all the virtual libraries in the closure. we need this to avoid + introducing impl -> lib -> vlib cycles. *) + vlib_closure : t Id.Map.t Resolve.t } let compare (x : t) (y : t) = Id.compare x.unique_id y.unique_id @@ -1101,6 +1114,30 @@ end = struct | Public (_, _) -> From_same_project in let resolve name = resolve_dep db name ~private_deps in + let* resolved = + let open Resolve.Build.O in + let* pps = + let instrumentation_backend = + instrumentation_backend db.instrument_with resolve + in + Lib_info.preprocess info + |> Preprocess.Per_module.with_instrumentation ~instrumentation_backend + >>| Preprocess.Per_module.pps + in + let dune_version = Lib_info.dune_version info in + Lib_info.requires info + |> resolve_deps_and_add_runtime_deps db ~private_deps ~dune_version ~pps + |> Memo.Build.map ~f:Resolve.return + in + let vlib_closure_parents = + let open Resolve.O in + let* resolved = resolved in + let* requires = resolved.requires in + Resolve.List.fold_left ~init:Id.Map.empty requires + ~f:(fun acc (lib : lib) -> + let+ vlib_closure = lib.vlib_closure in + Id.Map.superpose acc vlib_closure) + in let* implements = match Lib_info.implements info with | None -> Memo.Build.return None @@ -1115,6 +1152,30 @@ end = struct in Memo.Build.map res ~f:Option.some in + let requires = + let open Resolve.O in + match implements with + | None -> resolved >>= fun r -> r.requires + | Some vlib -> + let* vlib = vlib in + let* vlib_closure_parents = vlib_closure_parents in + if Id.Map.mem vlib_closure_parents vlib.unique_id then + let loc = Lib_info.loc info in + Error.vlib_in_closure ~loc ~impl:info ~vlib:vlib.info |> Resolve.fail + else + let* resolved = resolved in + let+ requires = resolved.requires in + List.filter requires ~f:(fun lib -> not (equal lib vlib)) + in + let vlib_closure = + let open Resolve.O in + let* vlib_closure_parents = vlib_closure_parents in + let+ requires = requires in + List.fold_left requires ~init:vlib_closure_parents ~f:(fun acc lib -> + match Lib_info.virtual_ lib.info with + | None -> acc + | Some _ -> Id.Map.set acc lib.unique_id lib) + in let resolve_impl impl_name = let open Resolve.Build.O in let* impl = resolve impl_name in @@ -1161,25 +1222,10 @@ end = struct (Package.Name.to_string p') ]))) in - let* resolved = - let open Resolve.Build.O in - let* pps = - let instrumentation_backend = - instrumentation_backend db.instrument_with resolve - in - Lib_info.preprocess info - |> Preprocess.Per_module.with_instrumentation ~instrumentation_backend - >>| Preprocess.Per_module.pps - in - let dune_version = Lib_info.dune_version info in - Lib_info.requires info - |> resolve_deps_and_add_runtime_deps db ~private_deps ~dune_version ~pps - |> Memo.Build.map ~f:Resolve.return - in let* requires = Memo.Build.return (let open Resolve.O in - let* requires = resolved >>= fun r -> r.requires in + let* requires = requires in match implements with | None -> Resolve.return requires | Some impl -> @@ -1252,6 +1298,7 @@ end = struct ~f:(fun name info -> Memo.Lazy.create (fun () -> Sub_system.instantiate name info (Lazy.force t) ~resolve)) + ; vlib_closure }) in let t = Lazy.force t in diff --git a/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t index 36b4bd7dfcce..65fb1aeef8f0 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t @@ -19,13 +19,22 @@ where vlib is a virtual library, and impl implements this library. $ cat >impl/dune < (library (name impl) (implements vlib) (libraries lib)) > EOF + $ dune build @all + File "impl/dune", line 1, characters 0-55: + 1 | (library (name impl) (implements vlib) (libraries lib)) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: Virtual library "vlib" is used by a dependency of "impl". This is not + allowed. + [1] The implementation impl was built, but it's not usable: $ echo 'Vlib.run ()' > foo.ml $ echo "(executable (name foo) (libraries impl))" > dune $ dune exec ./foo.exe - File "_none_", line 1: - Error: No implementations provided for the following modules: - Vlib referenced from lib/lib.cmxa(Lib) + File "impl/dune", line 1, characters 0-55: + 1 | (library (name impl) (implements vlib) (libraries lib)) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: Virtual library "vlib" is used by a dependency of "impl". This is not + allowed. [1] From 6bada31becc198a728fdd81927a16a5a62da6077 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 1 Nov 2021 17:49:42 -0600 Subject: [PATCH 20/32] refactor: simplify vlib impl closure check Use the already existing forbidden_libraries closure mechanism Signed-off-by: Rudi Grinberg ps-id: A5DF4B03-10EB-46F1-BC77-03C1D9E96A85 --- src/dune_rules/lib.ml | 64 ++++++------------- .../virtual-libraries/github2896.t/run.t | 21 +++--- 2 files changed, 31 insertions(+), 54 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 90b43992ad56..b2cd34d0e957 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -187,16 +187,6 @@ module Error = struct ] , [] ) - let vlib_in_closure ~loc ~impl ~vlib = - let impl = Lib_info.name impl in - let vlib = Lib_info.name vlib in - User_error.make ~loc - [ Pp.textf - "Virtual library %S is used by a dependency of %S. This is not \ - allowed." - (Lib_name.to_string vlib) (Lib_name.to_string impl) - ] - let only_ppx_deps_allowed ~loc dep = let name = Lib_info.name dep in make ~loc @@ -322,9 +312,6 @@ module T = struct ; sub_systems : Sub_system0.Instance.t Memo.Lazy.t Sub_system_name.Map.t ; modules : Modules.t Memo.Lazy.t option ; src_dirs : Path.Set.t Memo.Lazy.t - ; (* all the virtual libraries in the closure. we need this to avoid - introducing impl -> lib -> vlib cycles. *) - vlib_closure : t Id.Map.t Resolve.t } let compare (x : t) (y : t) = Id.compare x.unique_id y.unique_id @@ -1129,15 +1116,6 @@ end = struct |> resolve_deps_and_add_runtime_deps db ~private_deps ~dune_version ~pps |> Memo.Build.map ~f:Resolve.return in - let vlib_closure_parents = - let open Resolve.O in - let* resolved = resolved in - let* requires = resolved.requires in - Resolve.List.fold_left ~init:Id.Map.empty requires - ~f:(fun acc (lib : lib) -> - let+ vlib_closure = lib.vlib_closure in - Id.Map.superpose acc vlib_closure) - in let* implements = match Lib_info.implements info with | None -> Memo.Build.return None @@ -1152,29 +1130,28 @@ end = struct in Memo.Build.map res ~f:Option.some in - let requires = - let open Resolve.O in + let* requires = + let requires = + let open Resolve.O in + let* resolved = resolved in + resolved.requires + in match implements with - | None -> resolved >>= fun r -> r.requires + | None -> Memo.Build.return requires | Some vlib -> - let* vlib = vlib in - let* vlib_closure_parents = vlib_closure_parents in - if Id.Map.mem vlib_closure_parents vlib.unique_id then - let loc = Lib_info.loc info in - Error.vlib_in_closure ~loc ~impl:info ~vlib:vlib.info |> Resolve.fail - else - let* resolved = resolved in - let+ requires = resolved.requires in - List.filter requires ~f:(fun lib -> not (equal lib vlib)) - in - let vlib_closure = - let open Resolve.O in - let* vlib_closure_parents = vlib_closure_parents in - let+ requires = requires in - List.fold_left requires ~init:vlib_closure_parents ~f:(fun acc lib -> - match Lib_info.virtual_ lib.info with - | None -> acc - | Some _ -> Id.Map.set acc lib.unique_id lib) + let open Resolve.Build.O in + let* (_ : lib list) = + let* vlib = Memo.Build.return vlib in + let* requires_for_closure_check = + Memo.Build.return + (let open Resolve.O in + let+ requires = requires in + List.filter requires ~f:(fun lib -> not (equal lib vlib))) + in + linking_closure_with_overlap_checks None requires_for_closure_check + ~forbidden_libraries:(Map.singleton vlib Loc.none) + in + Memo.Build.return requires in let resolve_impl impl_name = let open Resolve.Build.O in @@ -1298,7 +1275,6 @@ end = struct ~f:(fun name info -> Memo.Lazy.create (fun () -> Sub_system.instantiate name info (Lazy.force t) ~resolve)) - ; vlib_closure }) in let t = Lazy.force t in diff --git a/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t index 65fb1aeef8f0..9ebaa55d7d12 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/github2896.t/run.t @@ -20,11 +20,12 @@ where vlib is a virtual library, and impl implements this library. > (library (name impl) (implements vlib) (libraries lib)) > EOF $ dune build @all - File "impl/dune", line 1, characters 0-55: - 1 | (library (name impl) (implements vlib) (libraries lib)) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: Virtual library "vlib" is used by a dependency of "impl". This is not - allowed. + Error: Library "vlib" was pulled in. + -> required by library "lib" in _build/default/lib + -> required by library "impl" in _build/default/impl + -> required by _build/default/impl/.impl.objs/byte/vlib.cmo + -> required by _build/default/impl/impl.cma + -> required by alias impl/all [1] The implementation impl was built, but it's not usable: @@ -32,9 +33,9 @@ The implementation impl was built, but it's not usable: $ echo 'Vlib.run ()' > foo.ml $ echo "(executable (name foo) (libraries impl))" > dune $ dune exec ./foo.exe - File "impl/dune", line 1, characters 0-55: - 1 | (library (name impl) (implements vlib) (libraries lib)) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: Virtual library "vlib" is used by a dependency of "impl". This is not - allowed. + Error: Library "vlib" was pulled in. + -> required by library "lib" in _build/default/lib + -> required by library "impl" in _build/default/impl + -> required by executable foo in dune:1 + -> required by _build/default/foo.exe [1] From cf04705301b336a1ae12ef7141e5613ed9ee9690 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Tue, 2 Nov 2021 16:27:32 +0000 Subject: [PATCH 21/32] Add more tests for the current behaviour of target promotion (#5076) I'm making some changes around the target promotion logic, so I'd like to add some more tests. Note that this reveals a bug in the file-watching mode. Signed-off-by: Andrey Mokhov --- .../promote/dep-on-promoted-target.t/run.t | 104 +++++++++++++++++ .../test-cases/promote/old-tests.t/run.t | 4 +- .../test-cases/watching/target-promotion.t | 108 ++++++++++++++++++ 3 files changed, 214 insertions(+), 2 deletions(-) create mode 100644 test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t/run.t create mode 100644 test/blackbox-tests/test-cases/watching/target-promotion.t diff --git a/test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t/run.t b/test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t/run.t new file mode 100644 index 000000000000..63c13e1aeddb --- /dev/null +++ b/test/blackbox-tests/test-cases/promote/dep-on-promoted-target.t/run.t @@ -0,0 +1,104 @@ +Depending on a promoted file works. + + $ cat > dune < (rule + > (mode promote) + > (deps original) + > (target promoted) + > (action (copy %{deps} %{target}))) + > (rule + > (deps promoted) + > (target result) + > (action (bash "cat promoted promoted > result"))) + > EOF + + $ echo hi > original + $ dune build result + $ cat promoted + hi + $ cat _build/default/result + hi + hi + +Now change the [original] and rebuild. + + $ echo bye > original + $ dune build result + $ cat promoted + bye + $ cat _build/default/result + bye + bye + +Now switch the mode to standard. Dune reports an error about multiple rules for +[_build/default/promoted], as expected. + + $ cat > dune < (rule + > (mode standard) + > (deps original) + > (target promoted) + > (action (copy %{deps} %{target}))) + > (rule + > (deps promoted) + > (target result) + > (action (bash "cat promoted promoted > result"))) + > EOF + + $ dune build result + Error: Multiple rules generated for _build/default/promoted: + - file present in source tree + - dune:1 + Hint: rm -f promoted + [1] + +We use the hint and it starts to work. + + $ rm -f promoted + $ dune build result + $ cat promoted + cat: promoted: No such file or directory + [1] + $ cat _build/default/promoted + bye + $ cat _build/default/result + bye + bye + +Now use [fallback] to override the rule that generates [promoted]. + + $ cat > dune < (rule + > (mode fallback) + > (deps original) + > (target promoted) + > (action (copy %{deps} %{target}))) + > (rule + > (deps promoted) + > (target result) + > (action (bash "cat promoted promoted > result"))) + > EOF + +At first, we don't have the source, so the rule is used. + + $ dune build result + $ cat promoted + cat: promoted: No such file or directory + [1] + $ cat _build/default/promoted + bye + $ cat _build/default/result + bye + bye + +Now we create the source file and it overrides the rule. + + $ echo hi > promoted + $ dune build result + $ cat promoted + hi + $ cat _build/default/promoted + hi + $ cat _build/default/result + hi + hi diff --git a/test/blackbox-tests/test-cases/promote/old-tests.t/run.t b/test/blackbox-tests/test-cases/promote/old-tests.t/run.t index 43d6310e533c..d81362bb8c6c 100644 --- a/test/blackbox-tests/test-cases/promote/old-tests.t/run.t +++ b/test/blackbox-tests/test-cases/promote/old-tests.t/run.t @@ -108,14 +108,14 @@ Only "only1" should be promoted in the source tree: $ ls -1 only* only1 -Test that Dune restores only1 if it's deleted from the source tree +Dune restores only1 if it's deleted from the source tree $ rm only1 $ dune build only2 $ ls -1 only* only1 -Test that Dune restores only1 if it's modified in the source tree +Dune restores only1 if it's modified in the source tree $ cat only1 0 diff --git a/test/blackbox-tests/test-cases/watching/target-promotion.t b/test/blackbox-tests/test-cases/watching/target-promotion.t new file mode 100644 index 000000000000..2abfc10ccdd8 --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/target-promotion.t @@ -0,0 +1,108 @@ +Test target promotion in file-watching mode. + + $ . ./helpers.sh + + $ echo '(lang dune 3.0)' > dune-project + $ cat > dune < (rule + > (mode promote) + > (deps original) + > (target promoted) + > (action (copy %{deps} %{target}))) + > (rule + > (deps promoted) + > (target result) + > (action (bash "cat promoted promoted > result"))) + > EOF + $ echo hi > original + + $ start_dune + + $ build result + Success + $ cat promoted + hi + $ cat _build/default/result + hi + hi + +Now change the [original] and rebuild. + + $ echo bye > original + $ build result + Success + $ cat promoted + bye + $ cat _build/default/result + bye + bye + +Now try deleting the promoted file. + + $ rm promoted + $ build result + Success + $ cat promoted + bye + $ cat _build/default/result + bye + bye + +Now try replacing its content. + + $ echo hi > promoted + $ build result + Success + $ cat promoted + bye + $ cat _build/default/result + bye + bye + +Now replace the content and switch the mode to standard. Note that this case is +currently not handled correctly: instead of succeeding, we should report a rule +conflict, as we do in the batch build mode -- see [dep-on-promoted-target.t]. + +# CR-someday amokhov: Fix this test. + + $ cat > dune < (rule + > (mode standard) + > (deps original) + > (target promoted) + > (action (copy %{deps} %{target}))) + > (rule + > (deps promoted) + > (target result) + > (action (bash "cat promoted promoted > result"))) + > EOF + $ echo hi > promoted + + $ build result + Success + $ cat promoted + hi + $ cat _build/default/promoted + bye + $ cat _build/default/result + bye + bye + +We're done. + + $ stop_dune + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... From 82386a1d401f27461c819b5a3f83f530932f9199 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 2 Nov 2021 16:28:49 +0000 Subject: [PATCH 22/32] Move annotations to User_message.t (#5075) Signed-off-by: Jeremie Dimino --- bin/arg.ml | 4 +- otherlibs/site/src/plugins/meta_parser.ml | 4 +- otherlibs/stdune-unstable/user_error.ml | 85 +++------------------- otherlibs/stdune-unstable/user_error.mli | 44 +---------- otherlibs/stdune-unstable/user_message.ml | 74 ++++++++++++++++++- otherlibs/stdune-unstable/user_message.mli | 45 +++++++++++- src/dune_engine/action.ml | 2 +- src/dune_engine/build_system.ml | 16 ++-- src/dune_engine/compound_user_error.ml | 2 +- src/dune_engine/compound_user_error.mli | 6 +- src/dune_engine/diff_promotion.ml | 2 +- src/dune_engine/diff_promotion.mli | 2 +- src/dune_engine/print_diff.ml | 3 +- src/dune_engine/print_diff.mli | 6 +- src/dune_engine/process.ml | 10 +-- src/dune_engine/process.mli | 6 +- src/dune_engine/sandbox.ml | 2 +- src/dune_engine/string_with_vars.ml | 6 +- src/dune_engine/utils.ml | 4 +- src/dune_lang/decoder.ml | 2 +- src/dune_rpc_server/dune_rpc_server.ml | 2 +- src/dune_rules/coq_lib.ml | 2 +- src/dune_rules/expander.ml | 2 +- src/dune_rules/findlib/findlib.ml | 15 ++-- src/dune_rules/lib.ml | 13 ++-- src/dune_rules/merlin_server.ml | 2 +- src/dune_rules/resolve.ml | 2 +- src/dune_rules/stanza_common.ml | 4 +- src/dune_rules/watermarks.ml | 2 +- src/dune_util/report_error.ml | 6 +- src/dune_util/stringlike.ml | 2 +- src/meta_parser/meta_parser.ml | 6 +- test/expect-tests/dune_lang/sexp_tests.ml | 6 +- 33 files changed, 200 insertions(+), 189 deletions(-) diff --git a/bin/arg.ml b/bin/arg.ml index 9d36c42b372b..0200d4eb2e65 100644 --- a/bin/arg.ml +++ b/bin/arg.ml @@ -71,7 +71,7 @@ module Dep = struct ~mode:Dune_lang.Parser.Mode.Single s) with | x -> `Ok x - | exception User_error.E (msg, _) -> `Error (User_message.to_string msg)) + | exception User_error.E msg -> `Error (User_message.to_string msg)) let string_of_alias ~recursive sv = let prefix = @@ -115,7 +115,7 @@ let bytes = Dune_lang.Decoder.parse Dune_lang.Decoder.bytes_unit Univ_map.empty ast with | x -> Result.Ok x - | exception User_error.E (msg, _) -> + | exception User_error.E msg -> Result.Error (`Msg (User_message.to_string msg)) in let pp_print_int64 state i = diff --git a/otherlibs/site/src/plugins/meta_parser.ml b/otherlibs/site/src/plugins/meta_parser.ml index d69230c9a214..1ccf738fde3e 100644 --- a/otherlibs/site/src/plugins/meta_parser.ml +++ b/otherlibs/site/src/plugins/meta_parser.ml @@ -27,13 +27,13 @@ module Meta_parser = Dune_meta_parser.Meta_parser.Make (struct module Style = struct type t = unit end - end - module User_error = struct module Annot = struct type t = unit end + end + module User_error = struct let raise ?loc:_ ?hints:_ ?annots:_ texts = invalid_arg (String.concat " " texts) end diff --git a/otherlibs/stdune-unstable/user_error.ml b/otherlibs/stdune-unstable/user_error.ml index 09b11c1bc226..7c5ac1ff2d3e 100644 --- a/otherlibs/stdune-unstable/user_error.ml +++ b/otherlibs/stdune-unstable/user_error.ml @@ -1,90 +1,25 @@ -module Annot = struct - type t = .. - - let format = ref (fun _ -> assert false) - - module type S = sig - type payload - - val make : payload -> t - - val check : t -> (payload -> 'a) -> (unit -> 'a) -> 'a - end - - module Make (M : sig - type payload - - val to_dyn : payload -> Dyn.t - end) : S with type payload = M.payload = struct - type payload = M.payload - - type t += A of M.payload - - let make t = A t - - let check t on_match on_failure = - match t with - | A t -> on_match t - | _ -> on_failure () - - let () = - let f = function - | A t -> Dyn.pp (M.to_dyn t) - | other -> !format other - in - format := f - end - - module Has_embedded_location = Make (struct - type payload = unit - - let to_dyn = Unit.to_dyn - end) - - module Needs_stack_trace = Make (struct - type payload = unit - - let to_dyn = Unit.to_dyn - end) -end - -exception E of User_message.t * Annot.t list +exception E of User_message.t let prefix = Pp.seq (Pp.tag User_message.Style.Error (Pp.verbatim "Error")) (Pp.char ':') -let make ?loc ?hints paragraphs = - User_message.make ?loc ?hints paragraphs ~prefix - -let raise ?loc ?hints ?(annots = []) paragraphs = - raise (E (make ?loc ?hints paragraphs, annots)) - -let is_loc_none loc = - match loc with - | None -> true - | Some loc -> loc = Loc0.none - -let has_embedded_location annots = - List.exists annots ~f:(fun annot -> - Annot.Has_embedded_location.check annot (fun () -> true) (fun () -> false)) - -let has_location (msg : User_message.t) annots = - (not (is_loc_none msg.loc)) || has_embedded_location annots +let make ?loc ?hints ?annots paragraphs = + User_message.make ?loc ?hints ?annots paragraphs ~prefix -let needs_stack_trace annots = - List.exists annots ~f:(fun annot -> - Annot.Needs_stack_trace.check annot (fun () -> true) (fun () -> false)) +let raise ?loc ?hints ?annots paragraphs = + raise (E (make ?loc ?hints ?annots paragraphs)) let () = Printexc.register_printer (function - | E (t, []) -> Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t)) - | E (t, annots) -> + | E ({ annots = []; _ } as t) -> + Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t)) + | E t -> let open Pp.O in let pp = User_message.pp t ++ Pp.vbox - (Pp.concat_map annots ~f:(fun annot -> - Pp.box (!Annot.format annot) ++ Pp.cut)) + (Pp.concat_map t.annots ~f:(fun annot -> + Pp.box (User_message.Annot.pp annot) ++ Pp.cut)) in Some (Format.asprintf "%a" Pp.to_fmt pp) | _ -> None) diff --git a/otherlibs/stdune-unstable/user_error.mli b/otherlibs/stdune-unstable/user_error.mli index 997f8fa5ea11..784ff179d549 100644 --- a/otherlibs/stdune-unstable/user_error.mli +++ b/otherlibs/stdune-unstable/user_error.mli @@ -1,43 +1,16 @@ (** Error meant for humans *) -module Annot : sig - type t - - module type S = sig - type payload - - val make : payload -> t - - val check : t -> (payload -> 'a) -> (unit -> 'a) -> 'a - end - - module Make (M : sig - type payload - - val to_dyn : payload -> Dyn.t - end) : S with type payload = M.payload - - (** The message has a location embed in the text. *) - module Has_embedded_location : S with type payload = unit - - (** The message needs a stack trace for clarity. *) - module Needs_stack_trace : S with type payload = unit -end - (** User errors are errors that users need to fix themselves in order to make progress. Since these errors are read by users, they should be simple to - understand for people who are not familiar with the dune codebase. - - The additional [Annot.t] is intended to carry extra context for other, - non-user-facing purposes (such as data for the RPC). *) -exception E of User_message.t * Annot.t list + understand for people who are not familiar with the dune codebase. *) +exception E of User_message.t (** Raise a user error. The arguments are interpreted in the same way as [User_message.make]. The first paragraph is prefixed with "Error:". *) val raise : ?loc:Loc0.t -> ?hints:User_message.Style.t Pp.t list - -> ?annots:Annot.t list + -> ?annots:User_message.Annot.t list -> User_message.Style.t Pp.t list -> _ @@ -45,18 +18,9 @@ val raise : val make : ?loc:Loc0.t -> ?hints:User_message.Style.t Pp.t list + -> ?annots:User_message.Annot.t list -> User_message.Style.t Pp.t list -> User_message.t (** The "Error:" prefix *) val prefix : User_message.Style.t Pp.t - -(** Returns [true] if the message has an explicit location or one embedded in - the text. *) -val has_location : User_message.t -> Annot.t list -> bool - -(** Returns [true] if the list contains [Annot.Has_embedded_location]. *) -val has_embedded_location : Annot.t list -> bool - -(** Returns [true] if the list contains [Annot.Needs_stack_trace]. *) -val needs_stack_trace : Annot.t list -> bool diff --git a/otherlibs/stdune-unstable/user_message.ml b/otherlibs/stdune-unstable/user_message.ml index ef0e7334814a..98befefdc133 100644 --- a/otherlibs/stdune-unstable/user_message.ml +++ b/otherlibs/stdune-unstable/user_message.ml @@ -13,6 +13,58 @@ module Style = struct | Ansi_styles of Ansi_color.Style.t list end +module Annot = struct + type t = .. + + let format = ref (fun _ -> assert false) + + let pp t = !format t + + module type S = sig + type payload + + val make : payload -> t + + val check : t -> (payload -> 'a) -> (unit -> 'a) -> 'a + end + + module Make (M : sig + type payload + + val to_dyn : payload -> Dyn.t + end) : S with type payload = M.payload = struct + type payload = M.payload + + type t += A of M.payload + + let make t = A t + + let check t on_match on_failure = + match t with + | A t -> on_match t + | _ -> on_failure () + + let () = + let f = function + | A t -> Dyn.pp (M.to_dyn t) + | other -> !format other + in + format := f + end + + module Has_embedded_location = Make (struct + type payload = unit + + let to_dyn = Unit.to_dyn + end) + + module Needs_stack_trace = Make (struct + type payload = unit + + let to_dyn = Unit.to_dyn + end) +end + module Print_config = struct type t = Style.t -> Ansi_color.Style.t list @@ -36,18 +88,19 @@ type t = { loc : Loc0.t option ; paragraphs : Style.t Pp.t list ; hints : Style.t Pp.t list + ; annots : Annot.t list } -let make ?loc ?prefix ?(hints = []) paragraphs = +let make ?loc ?prefix ?(hints = []) ?(annots = []) paragraphs = let paragraphs = match (prefix, paragraphs) with | None, l -> l | Some p, [] -> [ p ] | Some p, x :: l -> Pp.concat ~sep:Pp.space [ p; x ] :: l in - { loc; hints; paragraphs } + { loc; hints; paragraphs; annots } -let pp { loc; paragraphs; hints } = +let pp { loc; paragraphs; hints; annots = _ } = let open Pp.O in let paragraphs = match hints with @@ -120,3 +173,18 @@ let to_string t = Format.asprintf "%a" Pp.to_fmt (pp { t with loc = None }) |> String.drop_prefix ~prefix:"Error: " |> Option.value_exn |> String.trim + +let is_loc_none loc = + match loc with + | None -> true + | Some loc -> loc = Loc0.none + +let has_embedded_location msg = + List.exists msg.annots ~f:(fun annot -> + Annot.Has_embedded_location.check annot (fun () -> true) (fun () -> false)) + +let has_location msg = (not (is_loc_none msg.loc)) || has_embedded_location msg + +let needs_stack_trace msg = + List.exists msg.annots ~f:(fun annot -> + Annot.Needs_stack_trace.check annot (fun () -> true) (fun () -> false)) diff --git a/otherlibs/stdune-unstable/user_message.mli b/otherlibs/stdune-unstable/user_message.mli index 3e430044cb1a..6ac23a2a6650 100644 --- a/otherlibs/stdune-unstable/user_message.mli +++ b/otherlibs/stdune-unstable/user_message.mli @@ -22,6 +22,32 @@ module Style : sig | Ansi_styles of Ansi_color.Style.t list end +module Annot : sig + type t + + module type S = sig + type payload + + val make : payload -> t + + val check : t -> (payload -> 'a) -> (unit -> 'a) -> 'a + end + + module Make (M : sig + type payload + + val to_dyn : payload -> Dyn.t + end) : S with type payload = M.payload + + (** The message has a location embed in the text. *) + module Has_embedded_location : S with type payload = unit + + (** The message needs a stack trace for clarity. *) + module Needs_stack_trace : S with type payload = unit + + val pp : t -> Style.t Pp.t +end + (** A user message.contents composed of an optional file location and a list of paragraphs. @@ -30,11 +56,15 @@ end When hints are provided, they are printed as last paragraphs and prefixed with "Hint:". Hints should give indication to the user for how to fix the - issue. *) + issue. + + The [annots] field is intended to carry extra context for other, + non-user-facing purposes (such as data for the RPC). *) type t = { loc : Loc0.t option ; paragraphs : Style.t Pp.t list ; hints : Style.t Pp.t list + ; annots : Annot.t list } val pp : t -> Style.t Pp.t @@ -56,6 +86,7 @@ val make : ?loc:Loc0.t -> ?prefix:Style.t Pp.t -> ?hints:Style.t Pp.t list + -> ?annots:Annot.t list -> Style.t Pp.t list -> t @@ -71,3 +102,15 @@ val did_you_mean : string -> candidates:string list -> Style.t Pp.t list (** Produces a plain text representation of the error message, without the "Error: " prefix. *) val to_string : t -> string + +(** Returns [true] if the message has an explicit location or one embedded in + the text. *) +val has_location : t -> bool + +(** Returns [true] if the message's annotations contains + [Annot.Has_embedded_location]. *) +val has_embedded_location : t -> bool + +(** Returns [true] if the message's annotations contains + [Annot.Needs_stack_trace]. *) +val needs_stack_trace : t -> bool diff --git a/src/dune_engine/action.ml b/src/dune_engine/action.ml index c1f728e4ea94..d492d1e1ce7e 100644 --- a/src/dune_engine/action.ml +++ b/src/dune_engine/action.ml @@ -30,7 +30,7 @@ module Prog = struct in Utils.program_not_found_message ?hint ~loc ~context program - let raise t = raise (User_error.E (user_message t, [])) + let raise t = raise (User_error.E (user_message t)) let to_dyn { context; program; hint; loc = _ } = let open Dyn.Encoder in diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index f5ef62304528..498d8478b5fb 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -254,7 +254,7 @@ module Error = struct | e -> e in match e with - | User_error.E (_, annots) -> List.find_map annots ~f:extract_promote + | User_error.E msg -> List.find_map msg.annots ~f:extract_promote | _ -> None let extract_compound_error annot = @@ -267,9 +267,9 @@ module Error = struct | e -> e in match e with - | User_error.E (msg, annots) -> ( - let dir = List.find_map annots ~f:extract_dir in - match List.find_map annots ~f:extract_compound_error with + | User_error.E msg -> ( + let dir = List.find_map msg.annots ~f:extract_dir in + match List.find_map msg.annots ~f:extract_compound_error with | None -> (msg, [], dir) | Some { main; related } -> (main, related, dir)) | e -> @@ -1672,11 +1672,9 @@ end = struct else Fiber.with_error_handler f ~on_error:(fun exn -> match exn.exn with - | User_error.E (msg, annots) - when not (User_error.has_location msg annots) -> + | User_error.E msg when not (User_message.has_location msg) -> let msg = { msg with loc = Some loc } in - Exn_with_backtrace.reraise - { exn with exn = User_error.E (msg, annots) } + Exn_with_backtrace.reraise { exn with exn = User_error.E msg } | _ -> Exn_with_backtrace.reraise exn)) in wrap_fiber (fun () -> @@ -2179,7 +2177,7 @@ end = struct [ ("targets", Targets.to_dyn rule.targets) ] in User_error.raise ~loc:rule.loc - ~annots:[ User_error.Annot.Needs_stack_trace.make () ] + ~annots:[ User_message.Annot.Needs_stack_trace.make () ] [ Pp.textf "This rule defines a directory target %S that matches the \ requested path %S but the rule's action didn't produce it" diff --git a/src/dune_engine/compound_user_error.ml b/src/dune_engine/compound_user_error.ml index 22dcfc9f88a1..6196633745e7 100644 --- a/src/dune_engine/compound_user_error.ml +++ b/src/dune_engine/compound_user_error.ml @@ -39,7 +39,7 @@ module Annot = struct end include Annot -include User_error.Annot.Make (Annot) +include User_message.Annot.Make (Annot) let make ~main ~related = make (create ~main ~related) diff --git a/src/dune_engine/compound_user_error.mli b/src/dune_engine/compound_user_error.mli index d0be631ed116..a93144c98fb3 100644 --- a/src/dune_engine/compound_user_error.mli +++ b/src/dune_engine/compound_user_error.mli @@ -9,9 +9,9 @@ type t = private ; related : User_message.t list } -include User_error.Annot.S with type payload := t +include User_message.Annot.S with type payload := t val make : - main:User_message.t -> related:User_message.t list -> User_error.Annot.t + main:User_message.t -> related:User_message.t list -> User_message.Annot.t -val parse_output : dir:Path.t -> string -> User_error.Annot.t option +val parse_output : dir:Path.t -> string -> User_message.Annot.t option diff --git a/src/dune_engine/diff_promotion.ml b/src/dune_engine/diff_promotion.ml index d9319f315f49..4e6b2c1411b5 100644 --- a/src/dune_engine/diff_promotion.ml +++ b/src/dune_engine/diff_promotion.ml @@ -22,7 +22,7 @@ module Annot = struct ; in_build : Path.Build.t } - include User_error.Annot.Make (Promote_annot) + include User_message.Annot.Make (Promote_annot) end module File = struct diff --git a/src/dune_engine/diff_promotion.mli b/src/dune_engine/diff_promotion.mli index 9101c29c6e70..ebd9d6592e5f 100644 --- a/src/dune_engine/diff_promotion.mli +++ b/src/dune_engine/diff_promotion.mli @@ -9,7 +9,7 @@ module Annot : sig ; in_build : Path.Build.t } - include User_error.Annot.S with type payload := t + include User_message.Annot.S with type payload := t end module File : sig diff --git a/src/dune_engine/print_diff.ml b/src/dune_engine/print_diff.ml index a27b823a60dd..369625e89f94 100644 --- a/src/dune_engine/print_diff.ml +++ b/src/dune_engine/print_diff.ml @@ -118,7 +118,8 @@ let print ?(skip_trailing_cr = Sys.win32) annot path1 path2 = For this reason, we manually pass the below annotation. *) Internal_job ( Some loc - , [ annot; User_error.Annot.Has_embedded_location.make () ] )) + , [ annot; User_message.Annot.Has_embedded_location.make () ] + )) in (* Use "diff" if "patdiff" reported no differences *) normal_diff ()) diff --git a/src/dune_engine/print_diff.mli b/src/dune_engine/print_diff.mli index af3f27d50a8b..331b7adc9e59 100644 --- a/src/dune_engine/print_diff.mli +++ b/src/dune_engine/print_diff.mli @@ -2,4 +2,8 @@ open! Stdune (** Diff two files that are expected not to match. *) val print : - ?skip_trailing_cr:bool -> User_error.Annot.t -> Path.t -> Path.t -> _ Fiber.t + ?skip_trailing_cr:bool + -> User_message.Annot.t + -> Path.t + -> Path.t + -> _ Fiber.t diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index 644f94024a14..b91a15955a7e 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -6,7 +6,7 @@ module Event = Chrome_trace.Event module Timestamp = Event.Timestamp module Action_output_on_success = Execution_parameters.Action_output_on_success -module With_directory_annot = User_error.Annot.Make (struct +module With_directory_annot = User_message.Annot.Make (struct type payload = Path.t let to_dyn = Path.to_dyn @@ -154,8 +154,8 @@ module Io = struct end type purpose = - | Internal_job of Loc.t option * User_error.Annot.t list - | Build_job of Loc.t option * User_error.Annot.t list * Targets.t + | Internal_job of Loc.t option * User_message.Annot.t list + | Build_job of Loc.t option * User_message.Annot.t list * Targets.t let loc_and_annots_of_purpose = function | Internal_job (loc, annots) -> (loc, annots) @@ -477,7 +477,7 @@ end = struct | Has_output output -> if output.has_embedded_location then let annots = - User_error.Annot.Has_embedded_location.make () :: annots + User_message.Annot.Has_embedded_location.make () :: annots in match Compound_user_error.parse_output ~dir output.without_color with | None -> annots @@ -491,7 +491,7 @@ end = struct (* We don't use [User_error.make] as it would add the "Error: " prefix. We don't need this prefix as it is already included in the output of the command. *) - raise (User_error.E (User_message.make ?loc paragraphs, annots)) + raise (User_error.E (User_message.make ?loc ~annots paragraphs)) let verbose t ~id ~purpose ~output ~command_line ~dir = let open Pp.O in diff --git a/src/dune_engine/process.mli b/src/dune_engine/process.mli index b7029cfbe53d..4f0980efed5c 100644 --- a/src/dune_engine/process.mli +++ b/src/dune_engine/process.mli @@ -2,7 +2,7 @@ open Import -module With_directory_annot : User_error.Annot.S with type payload = Path.t +module With_directory_annot : User_message.Annot.S with type payload = Path.t (** How to handle sub-process failures *) type ('a, 'b) failure_mode = @@ -55,8 +55,8 @@ end (** Why a Fiber.t was run. The location and annotations will be attached to error messages. *) type purpose = - | Internal_job of Loc.t option * User_error.Annot.t list - | Build_job of Loc.t option * User_error.Annot.t list * Targets.t + | Internal_job of Loc.t option * User_message.Annot.t list + | Build_job of Loc.t option * User_message.Annot.t list * Targets.t (** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination. [stdout_to] [stderr_to] are released *) diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index 4673d6f6b250..6292b202ed9d 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -178,7 +178,7 @@ let rename_dir_recursively ~loc ~src_dir ~dst_dir = | Created -> () | Already_exists -> User_error.raise ~loc - ~annots:[ User_error.Annot.Needs_stack_trace.make () ] + ~annots:[ User_message.Annot.Needs_stack_trace.make () ] [ Pp.textf "This rule defines a directory target %S whose name conflicts with \ an internal directory used by Dune. Please use a different name." diff --git a/src/dune_engine/string_with_vars.ml b/src/dune_engine/string_with_vars.ml index 7eb40a411b93..1b4968f14ca6 100644 --- a/src/dune_engine/string_with_vars.ml +++ b/src/dune_engine/string_with_vars.ml @@ -76,7 +76,7 @@ let decode_manually f = | Pform v -> ( match f env v with | pform -> Pform (v, pform) - | exception User_error.E (msg, _) + | exception User_error.E msg when Pform.Env.syntax_version env < (3, 0) -> (* Before dune 3.0, unknown variable errors were delayed *) Error (v, msg))) @@ -253,7 +253,7 @@ struct (* The [let+ () = A.return () in ...] is to delay the error until the evaluation of the applicative *) let+ () = A.return () in - raise (User_error.E (msg, [])) + raise (User_error.E msg) | Pform (source, p) -> let+ v = f ~source p in if t.quoted then @@ -324,7 +324,7 @@ let encode t = ; parts = List.map t.parts ~f:(function | Text s -> Dune_lang.Template.Text s - | Error (_, msg) -> raise (User_error.E (msg, [])) + | Error (_, msg) -> raise (User_error.E msg) | Pform (source, pform) -> ( match Pform.encode_to_latest_dune_lang_version pform with | Pform_was_deleted -> diff --git a/src/dune_engine/utils.ml b/src/dune_engine/utils.ml index fa3668445615..19024d76bd36 100644 --- a/src/dune_engine/utils.ml +++ b/src/dune_engine/utils.ml @@ -46,10 +46,10 @@ let program_not_found_message ?context ?hint ~loc prog = prog let program_not_found ?context ?hint ~loc prog = - raise (User_error.E (program_not_found_message ?context ?hint ~loc prog, [])) + raise (User_error.E (program_not_found_message ?context ?hint ~loc prog)) let library_not_found ?context ?hint lib = - raise (User_error.E (not_found "Library %s not found" ?context ?hint lib, [])) + raise (User_error.E (not_found "Library %s not found" ?context ?hint lib)) let install_file ~(package : Package.Name.t) ~findlib_toolchain = let package = Package.Name.to_string package in diff --git a/src/dune_lang/decoder.ml b/src/dune_lang/decoder.ml index 319e509d4eec..fce07bbc51f3 100644 --- a/src/dune_lang/decoder.ml +++ b/src/dune_lang/decoder.ml @@ -594,7 +594,7 @@ let map_validate t ~f ctx state1 = | Some _ -> msg | None -> { msg with loc = Some (loc_between_states ctx state1 state2) } in - raise (User_error.E (msg, [])) + raise (User_error.E msg) (** TODO: Improve consistency of error messages, e.g. use %S consistently for field names: see [field_missing] and [field_present_too_many_times]. *) diff --git a/src/dune_rpc_server/dune_rpc_server.ml b/src/dune_rpc_server/dune_rpc_server.ml index 36ae881bdd55..4e334d3b42c0 100644 --- a/src/dune_rpc_server/dune_rpc_server.ml +++ b/src/dune_rpc_server/dune_rpc_server.ml @@ -548,7 +548,7 @@ struct ; Exn_with_backtrace.pp exn ] in - let e = { exn with exn = User_error.E (msg, []) } in + let e = { exn with exn = User_error.E msg } in Dune_util.Report_error.report e; Fiber.return ()) in diff --git a/src/dune_rules/coq_lib.ml b/src/dune_rules/coq_lib.ml index 92b7eec2857f..ff447aac6291 100644 --- a/src/dune_rules/coq_lib.ml +++ b/src/dune_rules/coq_lib.ml @@ -41,7 +41,7 @@ let package l = l.package module Error = struct let make ?loc ?hints paragraphs = - Error (User_error.E (User_error.make ?loc ?hints paragraphs, [])) + Error (User_error.E (User_error.make ?loc ?hints paragraphs)) let duplicate_theory_name theory = let loc, name = theory.Coq_stanza.Theory.name in diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index d8a0c6d020fe..d026505a4051 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -171,7 +171,7 @@ let isn't_allowed_in_this_position_message ~source = ] let isn't_allowed_in_this_position ~source = - raise (User_error.E (isn't_allowed_in_this_position_message ~source, [])) + raise (User_error.E (isn't_allowed_in_this_position_message ~source)) let expand_artifact ~source t a s = match t.lookup_artifacts with diff --git a/src/dune_rules/findlib/findlib.ml b/src/dune_rules/findlib/findlib.ml index 46d6010aa8b5..63aaba75993c 100644 --- a/src/dune_rules/findlib/findlib.ml +++ b/src/dune_rules/findlib/findlib.ml @@ -408,13 +408,12 @@ end = struct | Error (e, _, _) -> Error (User_error.E - ( User_message.make - [ Pp.textf "Unable to get entry modules of %s in %s. " - (Lib_name.to_string t.name) - (Path.to_string src_dir) - ; Pp.textf "error: %s" (Unix.error_message e) - ] - , [] )) + (User_message.make + [ Pp.textf "Unable to get entry modules of %s in %s. " + (Lib_name.to_string t.name) + (Path.to_string src_dir) + ; Pp.textf "error: %s" (Unix.error_message e) + ])) | Ok dir_contents -> let dir_contents = Fs_cache.Dir_contents.to_list dir_contents in let ext = Cm_kind.ext Cmi in @@ -435,7 +434,7 @@ end = struct (Loc.in_dir src_dir, name) with | Ok s -> Ok (Some s) - | Error e -> Error (User_error.E (e, [])))))) + | Error e -> Error (User_error.E e))))) in Lib_info.create ~path_kind:External ~loc ~name:t.name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ~synopsis ~main_module_name diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index b2cd34d0e957..376e08fb7a23 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -179,13 +179,12 @@ module Error = struct let private_deps_not_allowed ~loc private_dep = let name = Lib_info.name private_dep in User_error.E - ( User_error.make ~loc - [ Pp.textf - "Library %S is private, it cannot be a dependency of a public \ - library. You need to give %S a public name." - (Lib_name.to_string name) (Lib_name.to_string name) - ] - , [] ) + (User_error.make ~loc + [ Pp.textf + "Library %S is private, it cannot be a dependency of a public \ + library. You need to give %S a public name." + (Lib_name.to_string name) (Lib_name.to_string name) + ]) let only_ppx_deps_allowed ~loc dep = let name = Lib_info.name dep in diff --git a/src/dune_rules/merlin_server.ml b/src/dune_rules/merlin_server.ml index 66251eef4a89..610b3d44cfd9 100644 --- a/src/dune_rules/merlin_server.ml +++ b/src/dune_rules/merlin_server.ml @@ -64,7 +64,7 @@ let to_local file_path = the build context *) Ok (Path.drop_optional_build_context path |> Path.local_part) with - | User_error.E (mess, _) -> User_message.to_string mess |> error) + | User_error.E mess -> User_message.to_string mess |> error) | None -> Printf.sprintf "Path %S is not in dune workspace (%S)." file_path Path.(to_absolute_filename Path.root) diff --git a/src/dune_rules/resolve.ml b/src/dune_rules/resolve.ml index b84404a62cfc..d803ee977bdf 100644 --- a/src/dune_rules/resolve.ml +++ b/src/dune_rules/resolve.ml @@ -70,7 +70,7 @@ let args t = let open Action_builder.O in Command.Args.Dyn (read t >>| fun _ -> assert false) -let fail msg = Error { exn = User_error.E (msg, []); stack_frames = [] } +let fail msg = Error { exn = User_error.E msg; stack_frames = [] } let peek t = Result.map_error t ~f:ignore diff --git a/src/dune_rules/stanza_common.ml b/src/dune_rules/stanza_common.ml index 95870f0c38a6..519867210430 100644 --- a/src/dune_rules/stanza_common.ml +++ b/src/dune_rules/stanza_common.ml @@ -45,7 +45,7 @@ module Pkg = struct let default_exn ~loc project stanza = match default project stanza with | Ok p -> p - | Error msg -> raise (User_error.E ({ msg with loc = Some loc }, [])) + | Error msg -> raise (User_error.E { msg with loc = Some loc }) let resolve (project : Dune_project.t) name = let packages = Dune_project.packages project in @@ -88,7 +88,7 @@ module Pkg = struct and+ loc, name = located Package.Name.decode in match resolve p name with | Ok x -> x - | Error e -> raise (User_error.E ({ e with loc = Some loc }, [])) + | Error e -> raise (User_error.E { e with loc = Some loc }) let field ~stanza = map_validate diff --git a/src/dune_rules/watermarks.ml b/src/dune_rules/watermarks.ml index fd790f2a89ef..f865346e76b3 100644 --- a/src/dune_rules/watermarks.ml +++ b/src/dune_rules/watermarks.ml @@ -354,7 +354,7 @@ let subst vcs = let version = Dune_project.dune_version dune_project.project in let ok_exn = function | Ok s -> s - | Error e -> raise (User_error.E (e, [])) + | Error e -> raise (User_error.E e) in if version >= (3, 0) then metadata_from_dune_project () diff --git a/src/dune_util/report_error.ml b/src/dune_util/report_error.ml index a12502cc285a..f4d0f877273b 100644 --- a/src/dune_util/report_error.ml +++ b/src/dune_util/report_error.ml @@ -63,9 +63,9 @@ let get_error_from_exn = function ; has_embedded_location = false ; needs_stack_trace = false }) - | User_error.E (msg, annots) -> - let has_embedded_location = User_error.has_embedded_location annots in - let needs_stack_trace = User_error.needs_stack_trace annots in + | User_error.E msg -> + let has_embedded_location = User_message.has_embedded_location msg in + let needs_stack_trace = User_message.needs_stack_trace msg in { responsible = User; msg; has_embedded_location; needs_stack_trace } | Code_error.E e -> code_error ~loc:e.loc ~dyn_without_loc:(Code_error.to_dyn_without_loc e) diff --git a/src/dune_util/stringlike.ml b/src/dune_util/stringlike.ml index 524ca95b107d..b56fdd1d9be7 100644 --- a/src/dune_util/stringlike.ml +++ b/src/dune_util/stringlike.ml @@ -34,7 +34,7 @@ module Make (S : Stringlike_intf.S_base) = struct let parse_string_exn (loc, s) = match of_string_user_error (loc, s) with | Ok s -> s - | Error err -> raise (User_error.E (err, [])) + | Error err -> raise (User_error.E err) let conv = ( (fun s -> diff --git a/src/meta_parser/meta_parser.ml b/src/meta_parser/meta_parser.ml index ac5b86bffe9c..7ffb29b6e28d 100644 --- a/src/meta_parser/meta_parser.ml +++ b/src/meta_parser/meta_parser.ml @@ -23,17 +23,17 @@ module Make (Stdune : sig module Style : sig type t end - end - module User_error : sig module Annot : sig type t end + end + module User_error : sig val raise : ?loc:Loc.t -> ?hints:User_message.Style.t Pp.t list - -> ?annots:Annot.t list + -> ?annots:User_message.Annot.t list -> User_message.Style.t Pp.t list -> _ end diff --git a/test/expect-tests/dune_lang/sexp_tests.ml b/test/expect-tests/dune_lang/sexp_tests.ml index d7d5371e57f6..39be5f8c317d 100644 --- a/test/expect-tests/dune_lang/sexp_tests.ml +++ b/test/expect-tests/dune_lang/sexp_tests.ml @@ -30,7 +30,7 @@ let of_sexp = let%expect_test _ = (try ignore (parse of_sexp Univ_map.empty (Lazy.force sexp) : int) with - | User_error.E (msg, _) -> User_message.print { msg with loc = None }); + | User_error.E msg -> User_message.print { msg with loc = None }); [%expect {| Error: Field "foo" is present too many times |}] @@ -57,7 +57,7 @@ let parse s = (Dune_lang.Parser.parse_string ~fname:"" ~mode:Many s |> List.map ~f:Dune_lang.Ast.remove_locs) with - | User_error.E (msg, _) -> Error (string_of_user_error msg) + | User_error.E msg -> Error (string_of_user_error msg) | e -> Error (Printexc.to_string e) in print_dyn @@ -254,7 +254,7 @@ let test syntax sexp = Round_trip_success else Did_not_round_trip sexp' - | exception User_error.E (msg, _) -> + | exception User_error.E msg -> Did_not_parse_back (string_of_user_error msg) ) in let open Dyn.Encoder in From 1a8246309b3864ad7b33b4f9ab89c171127eb861 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 2 Nov 2021 16:31:21 +0000 Subject: [PATCH 23/32] Make odoc warnings.t test more reproducible Signed-off-by: Jeremie Dimino --- test/blackbox-tests/test-cases/odoc/warnings.t/run.t | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/test/blackbox-tests/test-cases/odoc/warnings.t/run.t b/test/blackbox-tests/test-cases/odoc/warnings.t/run.t index e35b4be11961..02949cbf02d7 100644 --- a/test/blackbox-tests/test-cases/odoc/warnings.t/run.t +++ b/test/blackbox-tests/test-cases/odoc/warnings.t/run.t @@ -1,3 +1,5 @@ + $ export BUILD_PATH_PREFIX_MAP=odoc=`command -v odoc` + As configured in the `dune` file at the root, this should be an error: $ dune build --only-packages=foo_doc @doc @@ -25,9 +27,9 @@ These packages are in a nested env, the option is disabled, should success with In release mode, no error: $ dune build -p foo_doc,foo_lib @doc - (cd _build/default/_doc/_odoc/pkg/foo_doc && /home/dim/.opam/4.12.0/bin/odoc compile --pkg foo_doc -o page-foo.odoc ../../../../foo_doc/foo.mld) + (cd _build/default/_doc/_odoc/pkg/foo_doc && odoc compile --pkg foo_doc -o page-foo.odoc ../../../../foo_doc/foo.mld) File "../../../../foo_doc/foo.mld", line 4, characters 0-0: End of text is not allowed in '[...]' (code). - (cd _build/default/foo_lib/.foo.objs/byte && /home/dim/.opam/4.12.0/bin/odoc compile -I . -I ../../../_doc/_odoc/pkg/foo_lib --pkg foo_lib -o foo.odoc foo.cmti) + (cd _build/default/foo_lib/.foo.objs/byte && odoc compile -I . -I ../../../_doc/_odoc/pkg/foo_lib --pkg foo_lib -o foo.odoc foo.cmti) File "foo_lib/foo.mli", line 1, characters 7-7: End of text is not allowed in '[...]' (code). From 60bceb438c31e9441b81bfb5f163575841aee2f4 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Tue, 2 Nov 2021 17:58:07 +0000 Subject: [PATCH 24/32] Add a test case for #5064 (#5077) I keep coming across #5064 so I tried to add a test reproducing it. I didn't quite manage, but I believe I managed to reproduce a related problem. Signed-off-by: Andrey Mokhov --- .../test-cases/watching/github5064.t | 62 +++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 test/blackbox-tests/test-cases/watching/github5064.t diff --git a/test/blackbox-tests/test-cases/watching/github5064.t b/test/blackbox-tests/test-cases/watching/github5064.t new file mode 100644 index 000000000000..60a743f485dc --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/github5064.t @@ -0,0 +1,62 @@ +A test case for #5064: errors when changing module dependencies in the +file-watching mode. + + $ . ./helpers.sh + + $ echo '(lang dune 3.0)' > dune-project + $ mkdir lib + $ cat > lib/dune < (library (name lib)) + > EOF + $ cat > dune < (executable (name x) (libraries lib)) + > EOF + $ echo 'let hello = "Hello"' > lib/a.ml + $ echo 'let world = "World"' > lib/b.ml + $ echo 'let message = A.hello ^ ", " ^ B.world' > lib/lib.ml + + $ echo 'print_endline Lib.message' > x.ml + + $ start_dune + + $ build x.exe + Success + $ _build/default/x.exe + Hello, World + +Now let's make [lib/a.ml] depend on [lib/b.ml]. It doesn't work! + + $ cat > lib/a.ml < let _ = B.world + > let hello = "Hello" + > EOF + + $ build x.exe + Failure + +Let's try a manual restart. + + $ stop_dune + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + File "_none_", line 1: + Error: No implementations provided for the following modules: + Lib__B referenced from lib/lib.cmxa(Lib__A) + Had errors, waiting for filesystem changes... + + $ start_dune + +It works now! + + $ build x.exe + Success + +We're done. + + $ stop_dune + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... From b3089db98d2d64dc4740e2b959802c03f0d3b9e9 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Tue, 2 Nov 2021 18:08:05 +0000 Subject: [PATCH 25/32] Attach stack traces to library resolution errors (#5079) Thanks to #5075 and #5047, we can now easily provide more information for some library resolution errors. I think it's pretty helpful to tell the user why the problematic library was required. In fact, in one of the tests, this was suggested as a future improvement. We could only do this for a subset of errors in this module, but after studying the new error messages, I think all of them got better. Signed-off-by: Andrey Mokhov --- src/dune_rules/lib.ml | 6 ++++-- .../package-mismatch1.t/run.t | 7 +++++-- .../test-cases/deprecated-library-name/features.t | 1 + .../test-cases/enabled_if/eif-context_name.t/run.t | 1 + .../test-cases/enabled_if/eif-ocaml_version.t/run.t | 1 + .../test-cases/enabled_if/eif-simple.t/run.t | 6 +++--- test/blackbox-tests/test-cases/exec-missing.t/run.t | 1 + .../test-cases/forbidden_libraries.t/run.t | 2 ++ .../test-cases/foreign-library.t/run.t | 3 +++ test/blackbox-tests/test-cases/github1541.t/run.t | 4 ++++ test/blackbox-tests/test-cases/lib.t/run.t | 5 +++++ test/blackbox-tests/test-cases/libexec.t/run.t | 6 ++++++ .../test-cases/optional-executable.t/run.t | 13 +++++++++++++ test/blackbox-tests/test-cases/optional.t/run.t | 5 +++++ .../test-cases/ppx-runtime-dependencies.t/run.t | 1 + .../virtual-libraries/impl-not-virtual.t/run.t | 1 + 16 files changed, 56 insertions(+), 7 deletions(-) diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 376e08fb7a23..43db0e898639 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -92,7 +92,9 @@ module Error = struct consider the library that triggered the error. *) let make ?loc ?hints paragraphs = - Resolve.Build.fail (User_error.make ?loc ?hints paragraphs) + Resolve.Build.fail + (User_error.make ?loc ?hints paragraphs + ~annots:[ User_message.Annot.Needs_stack_trace.make () ]) let pp_lib info = let name = Lib_info.name info in @@ -1193,7 +1195,7 @@ end = struct [ Pp.textf "default implementation belongs to package %s \ while virtual library belongs to package %s. \ - This is impossible\n" + This is impossible." (Package.Name.to_string p) (Package.Name.to_string p') ]))) diff --git a/test/blackbox-tests/test-cases/default-implementation/package-mismatch1.t/run.t b/test/blackbox-tests/test-cases/default-implementation/package-mismatch1.t/run.t index 5ee110fb5540..acc38c1475c2 100644 --- a/test/blackbox-tests/test-cases/default-implementation/package-mismatch1.t/run.t +++ b/test/blackbox-tests/test-cases/default-implementation/package-mismatch1.t/run.t @@ -24,6 +24,9 @@ A default implementation of a library must belong to the same package 6 | (default_implementation def_i)) ^^^^^ Error: default implementation belongs to package dummyfoo2 while virtual - library belongs to package dummyfoo1. This is impossible - + library belongs to package dummyfoo1. This is impossible. + -> required by _build/default/dummyfoo1.dune-package + -> required by _build/install/default/lib/dummyfoo1/dune-package + -> required by _build/default/dummyfoo1.install + -> required by alias install [1] diff --git a/test/blackbox-tests/test-cases/deprecated-library-name/features.t b/test/blackbox-tests/test-cases/deprecated-library-name/features.t index 425890e8732e..a4c601b6b054 100644 --- a/test/blackbox-tests/test-cases/deprecated-library-name/features.t +++ b/test/blackbox-tests/test-cases/deprecated-library-name/features.t @@ -95,6 +95,7 @@ that wasn't found: 1 | (executable (name prog) (libraries a)) ^ Error: Library "a" not found. + -> required by _build/default/c/prog.exe [1] Test that we can migrate top-level libraries diff --git a/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t b/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t index d669dc1b78b7..27c3fe84b1b0 100644 --- a/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t +++ b/test/blackbox-tests/test-cases/enabled_if/eif-context_name.t/run.t @@ -34,6 +34,7 @@ dune >= 2.8 18 | (libraries bar)) ^^^ Error: Library "bar" in _build/default is hidden (unsatisfied 'enabled_if'). + -> required by _build/default/bar_exe.exe [1] + The actual context diff --git a/test/blackbox-tests/test-cases/enabled_if/eif-ocaml_version.t/run.t b/test/blackbox-tests/test-cases/enabled_if/eif-ocaml_version.t/run.t index 9c7bff8c18c7..ecf6235087c2 100644 --- a/test/blackbox-tests/test-cases/enabled_if/eif-ocaml_version.t/run.t +++ b/test/blackbox-tests/test-cases/enabled_if/eif-ocaml_version.t/run.t @@ -10,4 +10,5 @@ This one is disabled (version too low) ^^^^^^^^^^ Error: Library "futurecaml" in _build/default is hidden (unsatisfied 'enabled_if'). + -> required by _build/default/main2.exe [1] diff --git a/test/blackbox-tests/test-cases/enabled_if/eif-simple.t/run.t b/test/blackbox-tests/test-cases/enabled_if/eif-simple.t/run.t index dbb5aaf3bf32..d0f07cbe00a5 100644 --- a/test/blackbox-tests/test-cases/enabled_if/eif-simple.t/run.t +++ b/test/blackbox-tests/test-cases/enabled_if/eif-simple.t/run.t @@ -28,7 +28,7 @@ Test the enabled_if field for libraries: 35 | (libraries foo)) ^^^ Error: Library "foo" in _build/default is hidden (unsatisfied 'enabled_if'). + -> required by library "bar" in _build/default + -> required by executable main in dune:44 + -> required by _build/default/main.exe [1] - -Ideally, the above message should mention the dependency path between -the requested target and the unsatisfied `enabled_if`. diff --git a/test/blackbox-tests/test-cases/exec-missing.t/run.t b/test/blackbox-tests/test-cases/exec-missing.t/run.t index ace69a61bd46..c679a3aa281b 100644 --- a/test/blackbox-tests/test-cases/exec-missing.t/run.t +++ b/test/blackbox-tests/test-cases/exec-missing.t/run.t @@ -5,4 +5,5 @@ When using dune exec, the external-lib-deps command refers to the executable: 3 | (libraries does-not-exist)) ^^^^^^^^^^^^^^ Error: Library "does-not-exist" not found. + -> required by _build/default/x.exe [1] diff --git a/test/blackbox-tests/test-cases/forbidden_libraries.t/run.t b/test/blackbox-tests/test-cases/forbidden_libraries.t/run.t index 91e9999380f3..ea689adf7af3 100644 --- a/test/blackbox-tests/test-cases/forbidden_libraries.t/run.t +++ b/test/blackbox-tests/test-cases/forbidden_libraries.t/run.t @@ -23,4 +23,6 @@ Test the `forbidden_libraries` feature Error: Library "a" was pulled in. -> required by library "b" in _build/default -> required by library "c" in _build/default + -> required by executable main in dune:5 + -> required by _build/default/main.exe [1] diff --git a/test/blackbox-tests/test-cases/foreign-library.t/run.t b/test/blackbox-tests/test-cases/foreign-library.t/run.t index b3cb2af39ca3..c83388da71f2 100644 --- a/test/blackbox-tests/test-cases/foreign-library.t/run.t +++ b/test/blackbox-tests/test-cases/foreign-library.t/run.t @@ -768,6 +768,9 @@ Testsuite for the (foreign_library ...) stanza. 4 | (include_dirs (lib answer) (lib unknown_lib)) ^^^^^^^^^^^ Error: Library "unknown_lib" not found. + -> required by _build/default/some/dir/src.o + -> required by _build/default/some/dir/libclib.a + -> required by _build/default/some/dir/main.exe [1] ---------------------------------------------------------------------------------- diff --git a/test/blackbox-tests/test-cases/github1541.t/run.t b/test/blackbox-tests/test-cases/github1541.t/run.t index 6d045bbb1b0e..2c5a40e03793 100644 --- a/test/blackbox-tests/test-cases/github1541.t/run.t +++ b/test/blackbox-tests/test-cases/github1541.t/run.t @@ -10,6 +10,8 @@ for libraries: 1 | (rule (with-stdout-to dummy (echo "%{lib:fakelib:bar.ml}"))) ^^^^^^^^^^^^^^^^^^^^^ Error: Library "fakelib" not found. + -> required by %{lib:fakelib:bar.ml} at dune:1 + -> required by _build/default/dummy [1] for binaries: @@ -31,6 +33,8 @@ for libraries in the deps field: 1 | (rule (deps %{lib:fakelib:bar.ml}) (target dummy) (action (with-stdout-to %{target} (echo foo)))) ^^^^^^^^^^^^^^^^^^^^^ Error: Library "fakelib" not found. + -> required by %{lib:fakelib:bar.ml} at dune:1 + -> required by _build/default/dummy [1] for binaries in the deps field: diff --git a/test/blackbox-tests/test-cases/lib.t/run.t b/test/blackbox-tests/test-cases/lib.t/run.t index cfea52628e62..71f5abb01d0b 100644 --- a/test/blackbox-tests/test-cases/lib.t/run.t +++ b/test/blackbox-tests/test-cases/lib.t/run.t @@ -251,4 +251,9 @@ But will fail when we release it, as it will need to run with -p: 5 | (with-stdout-to lib2.ml (echo "let _ = {|%{lib-private:lib1:lib1.ml}|}"))) ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Library "lib1" not found. + -> required by %{lib-private:lib1:lib1.ml} at lib2/dune:5 + -> required by _build/default/lib2/lib2.ml + -> required by _build/install/default/lib/public_lib2/lib2.ml + -> required by _build/default/public_lib2.install + -> required by alias install [1] diff --git a/test/blackbox-tests/test-cases/libexec.t/run.t b/test/blackbox-tests/test-cases/libexec.t/run.t index 31f8f5b181af..de2279156a47 100644 --- a/test/blackbox-tests/test-cases/libexec.t/run.t +++ b/test/blackbox-tests/test-cases/libexec.t/run.t @@ -313,4 +313,10 @@ But will fail when we release it, as it will need to run with -p: 5 | (with-stdout-to lib2.ml (echo "let _ = {|%{libexec-private:lib1:lib1.ml}|}"))) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Library "lib1" not found. + -> required by %{libexec-private:lib1:lib1.ml} at lib2/dune:5 + -> required by _build/target/lib2/lib2.ml + -> required by _build/install/target/lib/public_lib2/lib2.ml + -> required by _build/target/public_lib2.install + -> required by alias install (context target) + -> required by alias target (context target) in dune:5 [1] diff --git a/test/blackbox-tests/test-cases/optional-executable.t/run.t b/test/blackbox-tests/test-cases/optional-executable.t/run.t index 3484ab00b2bc..35a287291911 100644 --- a/test/blackbox-tests/test-cases/optional-executable.t/run.t +++ b/test/blackbox-tests/test-cases/optional-executable.t/run.t @@ -26,6 +26,8 @@ Test optional executable 3 | (libraries does-not-exist) ^^^^^^^^^^^^^^ Error: Library "does-not-exist" not found. + -> required by _build/default/x.exe + -> required by alias all [1] $ dune build @run-x @@ -33,6 +35,9 @@ Test optional executable 3 | (libraries does-not-exist) ^^^^^^^^^^^^^^ Error: Library "does-not-exist" not found. + -> required by _build/default/x.exe + -> required by %{exe:x.exe} at dune:8 + -> required by alias run-x in dune:6 [1] Reproduction case for a bug in dune < 2.4 where all executables where @@ -51,6 +56,10 @@ The following command should fail because the executable is not optional: 3 | (libraries does-not-exist)) ^^^^^^^^^^^^^^ Error: Library "does-not-exist" not found. + -> required by _build/default/x.exe + -> required by _build/install/default/bin/x + -> required by _build/default/x.install + -> required by alias install [1] A strange behavior discovered in #4786. Dune would ignore an executable if any @@ -130,6 +139,10 @@ present even if the binary is not optional. 3 | (libraries doesnotexistatall) ^^^^^^^^^^^^^^^^^ Error: Library "doesnotexistatall" not found. + -> required by _build/default/exe/bar.exe + -> required by _build/install/default/bin/dunetestbar + -> required by %{bin:dunetestbar} at dune:3 + -> required by alias run-x in dune:1 [1] Optional on the executable should be respected: diff --git a/test/blackbox-tests/test-cases/optional.t/run.t b/test/blackbox-tests/test-cases/optional.t/run.t index 49e176a4f374..425f94009382 100644 --- a/test/blackbox-tests/test-cases/optional.t/run.t +++ b/test/blackbox-tests/test-cases/optional.t/run.t @@ -46,4 +46,9 @@ The following command should fail because the executable is not optional: 4 | (libraries lib_that_doesn't_exist)) ^^^^^^^^^^^^^^^^^^^^^^ Error: Library "lib_that_doesn't_exist" not found. + -> required by library "foo" in _build/default + -> required by _build/default/META.foo + -> required by _build/install/default/lib/foo/META + -> required by _build/default/foo.install + -> required by alias install [1] diff --git a/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t b/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t index a8475ea84f4b..478446c1f0e8 100644 --- a/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t +++ b/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t @@ -115,6 +115,7 @@ not been marked with (kind ppx_rewriter). ^ Error: Ppx dependency on a non-ppx library "b". If "b" is in fact a ppx rewriter library, it should have (kind ppx_rewriter) in its dune file. + -> required by _build/default/bin/main.exe [1] ---------------------------------------------------------------------------------- diff --git a/test/blackbox-tests/test-cases/virtual-libraries/impl-not-virtual.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/impl-not-virtual.t/run.t index 4d1656edd8aa..2939ecab44d2 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/impl-not-virtual.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/impl-not-virtual.t/run.t @@ -5,4 +5,5 @@ appropriate error message. 3 | (implements lib)) ^^^ Error: Library "lib" is not virtual. It cannot be implemented by "impl". + -> required by alias default in dune:1 [1] From ecc6f2930f14c2abdaa94bbd69cb676f0fa532a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Tue, 2 Nov 2021 20:56:40 +0100 Subject: [PATCH 26/32] Remove/ignore .DS_Store files --- .DS_Store | Bin 6148 -> 0 bytes .gitignore | 2 ++ 2 files changed, 2 insertions(+) delete mode 100644 .DS_Store diff --git a/.DS_Store b/.DS_Store deleted file mode 100644 index 5008ddfcf53c02e82d7eee2e57c38e5672ef89f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~Jr2S!425mzP>H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0 Date: Tue, 12 Oct 2021 10:32:43 -0600 Subject: [PATCH 27/32] feature(fsevents): multliplex watchers Allow to create multiple watchers and run them in the same runloop Signed-off-by: Rudi Grinberg --- CHANGES.md | 3 + src/dune_engine/fs_memo.ml | 19 +- src/dune_file_watcher/dune_file_watcher.ml | 349 +++++++++++++----- src/dune_file_watcher/dune_file_watcher.mli | 2 +- src/fsevents/bin/dune_fsevents.ml | 9 +- src/fsevents/dune | 2 +- src/fsevents/fsevents.ml | 168 +++++++-- src/fsevents/fsevents.mli | 26 +- src/fsevents/fsevents_stubs.c | 112 ++++-- .../dune_file_watcher_tests_linux.ml | 8 +- test/expect-tests/fsevents/fsevents_tests.ml | 105 ++++-- test/expect-tests/fsevents/fsevents_tests.mli | 0 12 files changed, 601 insertions(+), 202 deletions(-) create mode 100644 test/expect-tests/fsevents/fsevents_tests.mli diff --git a/CHANGES.md b/CHANGES.md index 7ccc33c6a20f..b9d9f9fe9417 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,9 @@ Unreleased ---------- +- In watch mode, use fsevents instead of fswatch on OSX (#4937, #4990, fixes + #4896 @rgrinberg) + - Report cycles between virtual libraries and their implementation (#5050, fixes #2896, @rgrinberg) diff --git a/src/dune_engine/fs_memo.ml b/src/dune_engine/fs_memo.ml index 52e3134e9501..4e758ccab1d4 100644 --- a/src/dune_engine/fs_memo.ml +++ b/src/dune_engine/fs_memo.ml @@ -31,8 +31,9 @@ let t_ref = ref (Initialization_state.Uninitialized []) root is not sufficient to receive events for creation of "root/a/b/c/d". (however, subscribing to "root/a/b/c" is sufficient for that) *) let watch_path dune_file_watcher path = - try Dune_file_watcher.add_watch dune_file_watcher path with - | Unix.Unix_error (ENOENT, _, _) -> ( + match Dune_file_watcher.add_watch dune_file_watcher path with + | Ok () -> () + | Error `Does_not_exist -> ( (* If we're at the root of the workspace (or the unix root) then we can't get ENOENT because dune can't start without a workspace and unix root always exists, so this [_exn] can't raise (except if the user delets the @@ -42,9 +43,17 @@ let watch_path dune_file_watcher path = the parent. We still try to add a watch for the file itself after that succeeds, in case the file was created already before we started watching its parent. *) - Dune_file_watcher.add_watch dune_file_watcher containing_dir; - try Dune_file_watcher.add_watch dune_file_watcher path with - | Unix.Unix_error (ENOENT, _, _) -> ()) + (match Dune_file_watcher.add_watch dune_file_watcher containing_dir with + | Ok () -> () + | Error `Does_not_exist -> + Log.info + [ Pp.textf "attempted to add watch to non-existant directory %s" + (Path.to_string containing_dir) + ]); + match Dune_file_watcher.add_watch dune_file_watcher path with + | Error `Does_not_exist + | Ok () -> + ()) let watch_path_using_ref path = match !t_ref with diff --git a/src/dune_file_watcher/dune_file_watcher.ml b/src/dune_file_watcher/dune_file_watcher.ml index c8a1276e39d2..80b9998e4f46 100644 --- a/src/dune_file_watcher/dune_file_watcher.ml +++ b/src/dune_file_watcher/dune_file_watcher.ml @@ -20,28 +20,6 @@ let decompose_inotify_event (event : Inotify_lib.Event.t) = let inotify_event_paths event = List.map ~f:fst (decompose_inotify_event event) -type kind = - | Fswatch of - { pid : Pid.t - ; wait_for_watches_established : unit -> unit - } - | Fsevents of Fsevents.t - | Inotify of Inotify_lib.t - -type t = - { kind : kind - (* CR-someday amokhov: The way we handle "ignored files" using this - mutable table is fragile and also wrong. We use [ignored_files] for - the [(mode promote)] feature: if a file is promoted, we call - [ignore_next_file_change_event] so that the upcoming file-change - event does not invalidate the current build. However, instead of - ignoring the events, we should merely postpone them and restart the - build to take the promoted files into account if need be. *) - (* The [ignored_files] table should be accessed in the scheduler - thread. *) - ; ignored_files : (string, unit) Table.t - } - module Fs_memo_event = struct type kind = | Created @@ -80,6 +58,115 @@ module Event = struct | Watcher_terminated end +module Scheduler = struct + type t = + { spawn_thread : (unit -> unit) -> unit + ; thread_safe_send_emit_events_job : (unit -> Event.t list) -> unit + } +end + +module Watch_trie : sig + (** Specialized trie for fsevent watches *) + type 'a t + + val empty : 'a t + + val to_list : 'a t -> (Path.External.t * 'a) list + + type 'a add = + | Under_existing_node + | Inserted of + { new_t : 'a t + ; removed : (Path.External.t * 'a) list + } + + val add : 'a t -> Path.External.t -> 'a Lazy.t -> 'a add +end = struct + (* the invariant is that a node can contain either a value or branches, but + not both *) + type 'a t = + | Leaf of Path.External.t * 'a + | Branch of 'a t String.Map.t + + type 'a add = + | Under_existing_node + | Inserted of + { new_t : 'a t + ; removed : (Path.External.t * 'a) list + } + + let empty = Branch String.Map.empty + + let to_list t = + let rec loop t acc = + match t with + | Leaf (k, v) -> (k, v) :: acc + | Branch m -> String.Map.fold m ~init:acc ~f:loop + in + loop t [] + + let rec path p a = function + | [] -> Leaf (p, a) + | x :: xs -> Branch (String.Map.singleton x (path p a xs)) + + let add t key v = + (* wrong in general, but this is only needed for fsevents *) + let comps = + match String.split ~on:'/' (Path.External.to_string key) with + | "" :: comps -> comps + | _ -> + (* fsevents gives us only absolute paths *) + assert false + in + let rec add comps t = + match (comps, t) with + | _, Leaf (_, _) -> Under_existing_node + | [], Branch _ -> + Inserted { new_t = Leaf (key, Lazy.force v); removed = to_list t } + | x :: xs, Branch m -> ( + match String.Map.find m x with + | None -> + Inserted + { new_t = Branch (String.Map.set m x (path key (Lazy.force v) xs)) + ; removed = [] + } + | Some m' -> ( + match add xs m' with + | Under_existing_node -> Under_existing_node + | Inserted i -> + Inserted { i with new_t = Branch (String.Map.set m x i.new_t) })) + in + add comps t +end + +type kind = + | Fswatch of + { pid : Pid.t + ; wait_for_watches_established : unit -> unit + } + | Fsevents of + { mutable external_ : Fsevents.t Watch_trie.t + ; runloop : Fsevents.RunLoop.t + ; scheduler : Scheduler.t + ; source : Fsevents.t + ; sync : Fsevents.t + } + | Inotify of Inotify_lib.t + +type t = + { kind : kind + (* CR-someday amokhov: The way we handle "ignored files" using this + mutable table is fragile and also wrong. We use [ignored_files] for + the [(mode promote)] feature: if a file is promoted, we call + [ignore_next_file_change_event] so that the upcoming file-change + event does not invalidate the current build. However, instead of + ignoring the events, we should merely postpone them and restart the + build to take the promoted files into account if need be. *) + (* The [ignored_files] table should be accessed in the scheduler + thread. *) + ; ignored_files : (string, unit) Table.t + } + let exclude_patterns = [ {|/_opam|} ; {|/_esy|} @@ -157,13 +244,6 @@ let process_inotify_event ~ignored_files ]) | Queue_overflow -> [ Event.Queue_overflow ] -module Scheduler = struct - type t = - { spawn_thread : (unit -> unit) -> unit - ; thread_safe_send_emit_events_job : (unit -> Event.t list) -> unit - } -end - let shutdown t = match t.kind with | Fswatch { pid; _ } -> `Kill pid @@ -171,8 +251,11 @@ let shutdown t = | Fsevents fsevents -> `Thunk (fun () -> - List.iter [ Fsevents.stop; Fsevents.break; Fsevents.destroy ] - ~f:(fun f -> f fsevents)) + Fsevents.stop fsevents.source; + Fsevents.stop fsevents.sync; + Watch_trie.to_list fsevents.external_ + |> List.iter ~f:(fun (_, fs) -> Fsevents.stop fs); + Fsevents.RunLoop.stop fsevents.runloop) let buffer_capacity = 65536 @@ -216,13 +299,16 @@ module Buffer = struct List.rev !lines) end -let special_file_for_inotify_sync = - let path = lazy (Path.Build.relative Path.Build.root "dune-inotify-sync") in +let special_file_for_fs_sync = + let path = + lazy + (let dir = Path.Build.relative Path.Build.root ".sync" in + Path.Build.relative dir "token") + in fun () -> Lazy.force path let special_file_for_inotify_sync_absolute = - lazy - (Path.to_absolute_filename (Path.build (special_file_for_inotify_sync ()))) + lazy (Path.to_absolute_filename (Path.build (special_file_for_fs_sync ()))) let is_special_file_for_inotify_sync (path : Path.t) = match path with @@ -231,7 +317,7 @@ let is_special_file_for_inotify_sync (path : Path.t) = String.equal (Path.to_string path) (Lazy.force special_file_for_inotify_sync_absolute) | In_build_dir build_path -> - Path.Build.( = ) build_path (special_file_for_inotify_sync ()) + Path.Build.( = ) build_path (special_file_for_fs_sync ()) let command ~root ~backend = let exclude_paths = @@ -246,7 +332,7 @@ let command ~root ~backend = in let root = Path.to_string root in let inotify_special_path = - Path.Build.to_string (special_file_for_inotify_sync ()) + Path.Build.to_string (special_file_for_fs_sync ()) in match backend with | `Fswatch fswatch -> @@ -298,10 +384,12 @@ let select_watcher_backend () = fswatch_backend () let emit_sync () = - Io.write_file (Path.build (special_file_for_inotify_sync ())) "z" + let path = Path.build (special_file_for_fs_sync ()) in + Io.write_file path "z" let prepare_sync () = - Path.mkdir_p (Path.parent_exn (Path.build (special_file_for_inotify_sync ()))); + let dir = Path.parent_exn (Path.build (special_file_for_fs_sync ())) in + Path.mkdir_p dir; emit_sync () let spawn_external_watcher ~root ~backend = @@ -317,7 +405,7 @@ let spawn_external_watcher ~root ~backend = ((r_stdout, parse_line, wait), pid) let create_inotifylib_watcher ~ignored_files ~(scheduler : Scheduler.t) = - let special_file_for_inotify_sync = special_file_for_inotify_sync () in + let special_file_for_inotify_sync = special_file_for_fs_sync () in Inotify_lib.create ~spawn_thread:scheduler.spawn_thread ~modify_event_selector:`Closed_writable_fd ~send_emit_events_job_to_scheduler:(fun f -> @@ -418,61 +506,106 @@ let create_inotifylib ~scheduler = let ignored_files = Table.create (module String) 64 in let inotify = create_inotifylib_watcher ~ignored_files ~scheduler in Inotify_lib.add inotify - (Path.to_string (Path.build (special_file_for_inotify_sync ()))); + (Path.to_string (Path.build (special_file_for_fs_sync ()))); { kind = Inotify inotify; ignored_files } +let fsevents_callback (scheduler : Scheduler.t) ~f events = + scheduler.thread_safe_send_emit_events_job (fun () -> + List.filter_map events ~f:(fun event -> + let path = + Fsevents.Event.path event |> Path.of_string + |> Path.Expert.try_localize_external + in + f event path)) + +let fsevents ?exclusion_paths ~paths scheduler f = + let paths = List.map paths ~f:Path.to_absolute_filename in + let fsevents = + Fsevents.create ~latency:0.2 ~paths ~f:(fsevents_callback scheduler ~f) + in + Option.iter exclusion_paths ~f:(fun paths -> + Fsevents.set_exclusion_paths fsevents ~paths); + fsevents + +let fsevents_standard_event event ~ignored_files path = + let string_path = Fsevents.Event.path event in + if Table.mem ignored_files string_path then ( + Table.remove ignored_files string_path; + None + ) else + let action = Fsevents.Event.action event in + let kind = + match action with + | Unknown -> Fs_memo_event.Unknown + | Create -> Created + | Remove -> Deleted + | Modify -> + if Fsevents.Event.kind event = File then + File_changed + else + Unknown + in + Some (Event.Fs_memo_event { Fs_memo_event.kind; path }) + let create_fsevents ~(scheduler : Scheduler.t) = + prepare_sync (); let ignored_files = Table.create (module String) 64 in - let fsevents = - let paths = [ Path.to_string Path.root ] in - Fsevents.create ~paths ~latency:0.2 ~f:(fun _ events -> - scheduler.thread_safe_send_emit_events_job (fun () -> - List.filter_map events ~f:(fun event -> - let path = - Fsevents.Event.path event |> Path.of_string - |> Path.Expert.try_localize_external - in - let action = Fsevents.Event.action event in - if is_special_file_for_inotify_sync path then - match action with - | Unknown - | Create - | Modify -> - Some Event.Sync - | Remove -> None - else if Path.is_in_build_dir path then - (* we cannot ignore the build dir by setting the exclusion - path because we'd miss the sync events *) - None - else - let kind = - match action with - | Unknown -> Fs_memo_event.Unknown - | Create -> Created - | Remove -> Deleted - | Modify -> - if Fsevents.Event.kind event = File then - File_changed - else - Unknown - in - Some (Event.Fs_memo_event { Fs_memo_event.kind; path })))) + let sync = + fsevents scheduler + ~paths: + [ special_file_for_fs_sync () |> Path.Build.parent_exn |> Path.build ] + (fun event path -> + let action = Fsevents.Event.action event in + if is_special_file_for_inotify_sync path then + match action with + | Unknown + | Create + | Modify -> + Some Event.Sync + | Remove -> None + else + None) + in + let source = + let paths = [ Path.root ] in + let exclusion_paths = + Path.(build Build.root) + :: ([ "_esy"; "_opam"; ".git"; ".hg" ] + |> List.rev_map ~f:(fun base -> + let path = Path.relative (Path.source Path.Source.root) base in + path)) + |> List.rev_map ~f:Path.to_absolute_filename + in + fsevents scheduler ~exclusion_paths ~paths + (fsevents_standard_event ~ignored_files) in + let cv = Condition.create () in + let runloop_ref = ref None in + let mutex = Mutex.create () in scheduler.spawn_thread (fun () -> - Fsevents.start fsevents; - match Fsevents.loop fsevents with + let runloop = Fsevents.RunLoop.in_current_thread () in + Mutex.lock mutex; + runloop_ref := Some runloop; + Condition.signal cv; + Mutex.unlock mutex; + Fsevents.start source runloop; + Fsevents.start sync runloop; + match Fsevents.RunLoop.run_current_thread runloop with | Ok () -> () | Error exn -> Code_error.raise "fsevents callback raised" [ ("exn", Exn.to_dyn exn) ]); - Fsevents.set_exclusion_paths fsevents - ~paths: - ((* For now, we don't ignore the build directroy because we want to - receive events from the special event sync event *) - [ "_esy"; "_opam"; ".git"; ".hg" ] - |> List.rev_map ~f:(fun base -> - let path = Path.relative (Path.source Path.Source.root) base in - Path.to_absolute_filename path)); - { kind = Fsevents fsevents; ignored_files } + let external_ = Watch_trie.empty in + let runloop = + Mutex.lock mutex; + while !runloop_ref = None do + Condition.wait cv mutex + done; + Mutex.unlock mutex; + Option.value_exn !runloop_ref + in + { kind = Fsevents { scheduler; sync; source; external_; runloop } + ; ignored_files + } let create_external ~root ~debounce_interval ~scheduler ~backend = match debounce_interval with @@ -501,13 +634,51 @@ let wait_for_initial_watches_established_blocking t = let add_watch t path = match t.kind with - | Fsevents _ + | Fsevents f -> ( + match path with + | Path.In_source_tree _ -> (* already watched by source watcher *) Ok () + | In_build_dir _ -> + Code_error.raise "attempted to watch a directory in build" [] + | External ext -> ( + let ext = + let rec loop p = + if Path.is_directory (Path.external_ p) then + Some ext + else + match Path.External.parent p with + | None -> + User_warning.emit + [ Pp.textf "Refusing to watch %s" (Path.External.to_string ext) + ]; + None + | Some ext -> loop ext + in + loop ext + in + match ext with + | None -> Ok () + | Some ext -> ( + let watch = + lazy + (fsevents f.scheduler ~paths:[ path ] + (fsevents_standard_event ~ignored_files:t.ignored_files)) + in + match Watch_trie.add f.external_ ext watch with + | Watch_trie.Under_existing_node -> Ok () + | Inserted { new_t; removed } -> + let watch = Lazy.force watch in + Fsevents.start watch f.runloop; + List.iter removed ~f:(fun (_, fs) -> Fsevents.stop fs); + f.external_ <- new_t; + Ok ()))) | Fswatch _ -> (* Here we assume that the path is already being watched because the coarse file watchers are expected to watch all the source files from the start *) - () - | Inotify inotify -> Inotify_lib.add inotify (Path.to_string path) + Ok () + | Inotify inotify -> ( + try Ok (Inotify_lib.add inotify (Path.to_string path)) with + | Unix.Unix_error (ENOENT, _, _) -> Error `Does_not_exist) let ignore_next_file_change_event t path = assert (Path.is_in_source_tree path); diff --git a/src/dune_file_watcher/dune_file_watcher.mli b/src/dune_file_watcher/dune_file_watcher.mli index 43f4f360a00e..b07fecd17af0 100644 --- a/src/dune_file_watcher/dune_file_watcher.mli +++ b/src/dune_file_watcher/dune_file_watcher.mli @@ -72,7 +72,7 @@ val wait_for_initial_watches_established_blocking : t -> unit far. *) val emit_sync : unit -> unit -val add_watch : t -> Path.t -> unit +val add_watch : t -> Path.t -> (unit, [ `Does_not_exist ]) result (** Ignore the ne next file change event about this file. *) val ignore_next_file_change_event : t -> Path.t -> unit diff --git a/src/fsevents/bin/dune_fsevents.ml b/src/fsevents/bin/dune_fsevents.ml index 500a01a20e66..1276f7d160f7 100644 --- a/src/fsevents/bin/dune_fsevents.ml +++ b/src/fsevents/bin/dune_fsevents.ml @@ -8,8 +8,13 @@ let paths, latency = (!paths, !latency) let fsevents = - Fsevents.create ~paths ~latency ~f:(fun _ events -> + Fsevents.create ~paths ~latency ~f:(fun events -> ListLabels.iter events ~f:(fun evt -> Printf.printf "%s\n%!" (Dyn.to_string (Fsevents.Event.to_dyn_raw evt)))) -let () = Fsevents.start fsevents +let () = + let runloop = Fsevents.RunLoop.in_current_thread () in + Fsevents.start fsevents runloop; + match Fsevents.RunLoop.run_current_thread runloop with + | Ok () -> () + | Error e -> raise e diff --git a/src/fsevents/dune b/src/fsevents/dune index 9f564ab99102..0fa17a85f910 100644 --- a/src/fsevents/dune +++ b/src/fsevents/dune @@ -6,4 +6,4 @@ (foreign_stubs (language c) (names fsevents_stubs)) - (libraries dyn stdune)) + (libraries dyn threads.posix stdune)) diff --git a/src/fsevents/fsevents.ml b/src/fsevents/fsevents.ml index 502a48e9f052..e03d51e9272f 100644 --- a/src/fsevents/fsevents.ml +++ b/src/fsevents/fsevents.ml @@ -1,5 +1,84 @@ open Stdune +external available : unit -> bool = "dune_fsevents_available" + +module State : sig + type 'a t + + val create : 'a -> 'a t + + type 'a ref + + val get : 'a ref -> 'a + + val set : 'a ref -> 'a -> unit + + val critical_section : 'a t -> ('a ref -> 'b) -> 'b +end = struct + type 'a t = + { mutex : Mutex.t + ; mutable data : 'a + } + + type 'a ref = 'a t + + let set t a = t.data <- a + + let get t = t.data + + let create data = { mutex = Mutex.create (); data } + + let critical_section (type a) (t : a t) f = + Mutex.lock t.mutex; + Fun.protect (fun () -> f t) ~finally:(fun () -> Mutex.unlock t.mutex) +end + +module RunLoop = struct + module Raw = struct + type t + + external in_current_thread : unit -> t = "dune_fsevents_runloop_current" + + (* After this function terminates, the reference to [t] is no longer + valid *) + external run_current_thread : t -> unit = "dune_fsevents_runloop_run" + + external stop : t -> unit = "dune_fsevents_runloop_stop" + end + + type state = + | Idle of Raw.t + | Running of Raw.t + | Stopped + + type t = state State.t + + let in_current_thread () = State.create (Idle (Raw.in_current_thread ())) + + let stop (t : t) = + State.critical_section t (fun t -> + match State.get t with + | Running raw -> + State.set t Stopped; + Raw.stop raw + | Stopped -> () + | Idle _ -> Code_error.raise "RunLoop.stop: not started" []) + + let run_current_thread t = + let w = + State.critical_section t (fun t -> + match State.get t with + | Stopped -> Code_error.raise "RunLoop.run_current_thread: stopped" [] + | Running _ -> + Code_error.raise "RunLoop.run_current_thread: running" [] + | Idle w -> + State.set t (Running w); + w) + in + try Ok (Raw.run_current_thread w) with + | exn -> Error exn +end + module Event = struct module Id = struct type t @@ -144,48 +223,89 @@ module Event = struct ] end -type t - -external available : unit -> bool = "dune_fsevents_available" - -external stop : t -> unit = "dune_fsevents_stop" +module Raw = struct + type t -external start : t -> unit = "dune_fsevents_start" + external stop : t -> unit = "dune_fsevents_stop" -external loop : t -> unit = "dune_fsevents_loop" + external start : t -> RunLoop.Raw.t -> unit = "dune_fsevents_start" -let loop t = - match loop t with - | exception exn -> Error exn - | () -> Ok () + external create : string list -> float -> (Event.t list -> unit) -> t + = "dune_fsevents_create" -external break : t -> unit = "dune_fsevents_break" + external set_exclusion_paths : t -> string list -> unit + = "dune_fsevents_set_exclusion_paths" -external flush_sync : t -> unit = "dune_fsevents_flush_sync" + external flush_sync : t -> unit = "dune_fsevents_flush_sync" -external destroy : t -> unit = "dune_fsevents_destroy" + (* external flush_async : t -> Event.Id.t = "dune_fsevents_flush_async" *) +end -external dune_fsevents_create : - string list -> float -> (t -> Event.t list -> unit) -> t - = "dune_fsevents_create" +type state = + | Idle of Raw.t + | Start of Raw.t * RunLoop.t + | Stop of RunLoop.t + +type t = state State.t + +let stop t = + State.critical_section t (fun t -> + match State.get t with + | Idle _ -> Code_error.raise "Fsevents.stop: idle" [] + | Stop _ -> () + | Start (raw, rl) -> + State.set t (Stop rl); + Raw.stop raw) + +let start t (rl : RunLoop.t) = + State.critical_section t (fun t -> + match State.get t with + | Stop _ -> Code_error.raise "Fsevents.start: stop" [] + | Start _ -> Code_error.raise "Fsevents.start: start" [] + | Idle r -> + State.critical_section rl (fun rl' -> + match State.get rl' with + | Stopped -> Code_error.raise "Fsevents.start: runloop stopped" [] + | Idle rl' + | Running rl' -> + State.set t (Start (r, rl)); + Raw.start r rl')) + +let runloop t = + State.critical_section t (fun t -> + match State.get t with + | Idle _ -> None + | Start (_, rl) + | Stop rl -> + Some rl) + +let flush_sync t = + let t = + State.critical_section t (fun t -> + match State.get t with + | Idle _ -> Code_error.raise "Fsevents.flush_sync: idle" [] + | Stop _ -> Code_error.raise "Fsevents.flush_sync: stop" [] + | Start (r, _) -> r) + in + Raw.flush_sync t let create ~paths ~latency ~f = (match paths with | [] -> Code_error.raise "Fsevents.create: paths empty" [] | _ -> ()); - dune_fsevents_create paths latency f - -(* external flush_async : t -> Event.Id.t = "dune_fsevents_flush_async" *) - -external set_exclusion_paths : t -> string list -> unit - = "dune_fsevents_set_exclusion_paths" + State.create (Idle (Raw.create paths latency f)) let set_exclusion_paths t ~paths = if List.length paths > 8 then Code_error.raise "Fsevents.set_exclusion_paths: 8 directories should be enough for anybody" [ ("paths", Dyn.Encoder.(list string) paths) ]; - set_exclusion_paths t paths + State.critical_section t (fun t -> + match State.get t with + | Stop _ -> Code_error.raise "Fsevents.set_exclusion_paths: stop" [] + | Idle r + | Start (r, _) -> + Raw.set_exclusion_paths r paths) (* let flush_async t = *) (* let res = flush_async t in *) diff --git a/src/fsevents/fsevents.mli b/src/fsevents/fsevents.mli index 4f2f3a039066..3216e3cb3179 100644 --- a/src/fsevents/fsevents.mli +++ b/src/fsevents/fsevents.mli @@ -4,6 +4,16 @@ val available : unit -> bool +module RunLoop : sig + type t + + val in_current_thread : unit -> t + + val run_current_thread : t -> (unit, exn) result + + val stop : t -> unit +end + module Event : sig module Id : sig (** monotonically increasing id *) @@ -55,26 +65,18 @@ type t (** [create ~paths ~latency ~f] create a new watcher watching [paths], with debouncing based on [latency]. [f] is called for every new event *) -val create : - paths:string list -> latency:float -> f:(t -> Event.t list -> unit) -> t +val create : paths:string list -> latency:float -> f:(Event.t list -> unit) -> t (** [start t] will start listening for fsevents. Note that the callback will not be called until [loop t] is called. *) -val start : t -> unit +val start : t -> RunLoop.t -> unit + +val runloop : t -> RunLoop.t option (** [stop t] stop listening to events. Note that this will not make [loop] return until [break] is called. *) val stop : t -> unit -(** [loop t] start the event loop and execute the callback for the fsevents. *) -val loop : t -> (unit, exn) result - -(** [break t] stop the event loop. This will make [loop t] terminate. *) -val break : t -> unit - -(** [destroy t] cleanup the resources held by [t] *) -val destroy : t -> unit - (** [flush_sync t] flush all pending events that might be held up by debouncing. this function blocks until the final invocation of the callback for all buffered events completes. *) diff --git a/src/fsevents/fsevents_stubs.c b/src/fsevents/fsevents_stubs.c index cf7bf6c5e5ca..26ff0c6f9e53 100644 --- a/src/fsevents/fsevents_stubs.c +++ b/src/fsevents/fsevents_stubs.c @@ -9,13 +9,52 @@ #include #include +typedef struct dune_runloop { + CFRunLoopRef runloop; + value v_exn; +} dune_runloop; + typedef struct dune_fsevents_t { - CFRunLoopRef runLoop; + dune_runloop *runloop; value v_callback; FSEventStreamRef stream; value v_exn; } dune_fsevents_t; +CAMLprim value dune_fsevents_runloop_current(value v_unit) { + CAMLparam1(v_unit); + dune_runloop *rl; + rl = caml_stat_alloc(sizeof(dune_runloop)); + rl->runloop = CFRunLoopGetCurrent(); + rl->v_exn = Val_unit; + caml_register_global_root(&rl->v_exn); + CAMLreturn(caml_copy_nativeint((intnat)rl)); +} + +CAMLprim value dune_fsevents_runloop_run(value v_runloop) { + CAMLparam1(v_runloop); + CAMLlocal1(v_exn); + dune_runloop *runloop = (dune_runloop *)Nativeint_val(v_runloop); + caml_release_runtime_system(); + CFRunLoopRun(); + caml_acquire_runtime_system(); + caml_remove_global_root(&runloop->v_exn); + v_exn = runloop->v_exn; + caml_stat_free(runloop); + if (v_exn != Val_unit) + caml_raise(v_exn); + CAMLreturn(Val_unit); +} + +CAMLprim value dune_fsevents_runloop_stop(value v_runloop) { + CAMLparam1(v_runloop); + dune_runloop *runloop = (dune_runloop *)Nativeint_val(v_runloop); + caml_release_runtime_system(); + CFRunLoopStop(runloop->runloop); + caml_acquire_runtime_system(); + CAMLreturn(Val_unit); +} + static FSEventStreamEventFlags interesting_flags = kFSEventStreamEventFlagItemCreated | kFSEventStreamEventFlagItemRemoved | kFSEventStreamEventFlagItemRenamed | kFSEventStreamEventFlagItemModified | @@ -66,13 +105,10 @@ static void dune_fsevents_callback(const FSEventStreamRef streamRef, Store_field(v_events_x, 1, v_events_xs); v_events_xs = v_events_x; } - // TODO what happens if this function raises? - v_res = caml_callback2_exn(t->v_callback, caml_copy_nativeint((intnat)t), v_events_xs); + v_res = caml_callback_exn(t->v_callback, v_events_xs); if (Is_exception_result(v_res)) { - t->v_exn = Extract_exception(v_res); - FSEventStreamStop(t->stream); - FSEventStreamInvalidate(t->stream); - CFRunLoopStop(t->runLoop); + t->runloop->v_exn = Extract_exception(v_res); + CFRunLoopStop(t->runloop->runloop); } CAMLdrop; caml_release_runtime_system(); @@ -120,10 +156,8 @@ CAMLprim value dune_fsevents_create(value v_paths, value v_latency, flags); CFRelease(paths); caml_register_global_root(&t->v_callback); - caml_register_global_root(&t->v_exn); t->v_callback = v_callback; t->stream = stream; - t->v_exn = Val_unit; CAMLreturn(caml_copy_nativeint((intnat)t)); } @@ -143,54 +177,48 @@ CAMLprim value dune_fsevents_set_exclusion_paths(value v_t, value v_paths) { CAMLreturn(Val_unit); } -CAMLprim value dune_fsevents_start(value v_t) { - CAMLparam1(v_t); +CAMLprim value dune_fsevents_start(value v_t, value v_runloop) { + CAMLparam2(v_t, v_runloop); dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); - CFRunLoopRef runLoop = CFRunLoopGetCurrent(); - t->runLoop = runLoop; - FSEventStreamScheduleWithRunLoop(t->stream, runLoop, kCFRunLoopDefaultMode); + dune_runloop *runloop = (dune_runloop *)Nativeint_val(v_runloop); + t->runloop = runloop; + FSEventStreamScheduleWithRunLoop(t->stream, runloop->runloop, + kCFRunLoopDefaultMode); bool res = FSEventStreamStart(t->stream); if (!res) { + /* the docs say this is impossible anyway */ caml_failwith("Fsevents.start: failed to start"); } CAMLreturn(Val_unit); } -CAMLprim value dune_fsevents_destroy(value v_t) { +CAMLprim value dune_fsevents_stop(value v_t) { CAMLparam1(v_t); dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); + FSEventStreamStop(t->stream); + FSEventStreamInvalidate(t->stream); FSEventStreamRelease(t->stream); caml_remove_global_root(&t->v_callback); - caml_remove_global_root(&t->v_exn); caml_stat_free(t); CAMLreturn(Val_unit); } -CAMLprim value dune_fsevents_loop(value v_t) { - CAMLparam1(v_t); - dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); - caml_release_runtime_system(); - CFRunLoopRun(); - caml_acquire_runtime_system(); - if(t->v_exn != Val_unit) { - caml_raise(t->v_exn); - } - CAMLreturn(Val_unit); -} - -CAMLprim value dune_fsevents_stop(value v_t) { - CAMLparam1(v_t); - dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); - FSEventStreamStop(t->stream); - CAMLreturn(Val_unit); +static inline value Val_some(value v) { + CAMLparam1(v); + CAMLlocal1(some); + some = caml_alloc_small(1, 0); + Field(some, 0) = v; + CAMLreturn(some); } -CAMLprim value dune_fsevents_break(value v_t) { +CAMLprim value dune_fsevents_runloop_get(value v_t) { CAMLparam1(v_t); dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); - FSEventStreamInvalidate(t->stream); - CFRunLoopStop(t->runLoop); - CAMLreturn(Val_unit); + if (t->runloop == NULL) { + CAMLreturn(Val_int(0)); + } else { + CAMLreturn(Val_some(caml_copy_nativeint((intnat)t->runloop))); + } } CAMLprim value dune_fsevents_flush_async(value v_t) { @@ -350,6 +378,16 @@ CAMLprim value dune_fsevents_loop(value v_t) { caml_failwith("fsevents is only available on macos"); } +CAMLprim value dune_fsevents_runloop_current(value v_unit) { + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_runloop_run(value v_unit) { + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_runloop_stop(value v_runloop) { + caml_failwith("fsevents is only available on macos"); +} + CAMLprim value dune_fsevents_available(value unit) { CAMLparam1(unit); CAMLreturn(Val_false); diff --git a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml index a56de9253c99..8f05cd40041c 100644 --- a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml +++ b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml @@ -36,7 +36,9 @@ let%expect_test _ = | Watcher_terminated -> assert false))) in let print_events n = print_events ~try_to_get_events ~expected:n in - Dune_file_watcher.add_watch watcher (Path.of_string "."); + (match Dune_file_watcher.add_watch watcher (Path.of_string ".") with + | Error _ -> assert false + | Ok () -> ()); Dune_file_watcher.wait_for_initial_watches_established_blocking watcher; Stdio.Out_channel.write_all "x" ~data:"x"; print_events 2; @@ -54,7 +56,9 @@ let%expect_test _ = { path = In_source_tree "y"; kind = "Created" } |}]; let (_ : _) = Fpath.mkdir_p "d/w" in - Dune_file_watcher.add_watch watcher (Path.of_string "d/w"); + (match Dune_file_watcher.add_watch watcher (Path.of_string "d/w") with + | Error _ -> assert false + | Ok () -> ()); Stdio.Out_channel.write_all "d/w/x" ~data:"x"; print_events 3; [%expect diff --git a/test/expect-tests/fsevents/fsevents_tests.ml b/test/expect-tests/fsevents/fsevents_tests.ml index d91fa5de67ee..32288f161917 100644 --- a/test/expect-tests/fsevents/fsevents_tests.ml +++ b/test/expect-tests/fsevents/fsevents_tests.ml @@ -13,9 +13,13 @@ let start_filename = ".dune_fsevents_start" let end_filename = ".dune_fsevents_end" -let emit_start () = Io.String_path.write_file start_filename "" +let emit_start dir = + ignore (Fpath.mkdir_p dir); + Io.String_path.write_file (Filename.concat dir start_filename) "" -let emit_end () = Io.String_path.write_file end_filename "" +let emit_end dir = + ignore (Fpath.mkdir_p dir); + Io.String_path.write_file (Filename.concat dir end_filename) "" let test f = let cv = Condition.create () in @@ -68,10 +72,11 @@ let print_event ~cwd e = in printfn "> %s" (Dyn.to_string dyn) -let make_callback ~f = +let make_callback t ~f = (* hack to skip the first event if it's creating the temp dir *) let state = ref `Looking_start in - fun t events -> + fun events -> + let t = Option.value_exn !t in let is_marker event filename = Event.kind event = File && Filename.basename (Event.path event) = filename @@ -80,7 +85,7 @@ let make_callback ~f = let stop = lazy (Fsevents.stop t; - Fsevents.break t) + Fsevents.RunLoop.stop (Option.value_exn (Fsevents.runloop t))) in let events = List.fold_left events ~init:[] ~f:(fun acc event -> @@ -101,50 +106,72 @@ let make_callback ~f = | [] -> () | _ -> f events -let fsevents ?on_event ~cwd ~paths () = - let on_event = - match on_event with - | None -> print_event ~cwd - | Some s -> s - in - Fsevents.create ~paths - ~f:(make_callback ~f:(List.iter ~f:on_event)) - ~latency:0. +type test_config = + { on_events : Event.t list -> unit + ; exclusion_paths : string list + ; dir : string + } -let test_with_operations ?on_event ?exclusion_paths f = +let default_test_config cwd = + { on_events = List.iter ~f:(print_event ~cwd) + ; dir = cwd + ; exclusion_paths = [] + } + +let test_with_multiple_fsevents ~setup ~test:f = test (fun finish -> let cwd = Sys.getcwd () in - let t = fsevents ?on_event ~paths:[ cwd ] ~cwd () in - (match exclusion_paths with - | None -> () - | Some f -> - let paths = f cwd in - Fsevents.set_exclusion_paths t ~paths); - Fsevents.start t; + let configs = setup ~cwd (default_test_config cwd) in + let fsevents = + List.map configs ~f:(fun config -> + let t = ref None in + let res = + Fsevents.create ~paths:[ config.dir ] ~latency:0.0 + ~f:(make_callback t ~f:config.on_events) + in + t := Some res; + res) + in + let runloop = Fsevents.RunLoop.in_current_thread () in + List.iter fsevents ~f:(fun f -> Fsevents.start f runloop); let (_ : Thread.t) = Thread.create (fun () -> - emit_start (); + List.iter configs ~f:(fun config -> emit_start config.dir); f (); - emit_end ()) + List.iter configs ~f:(fun config -> emit_end config.dir)) () in - (match Fsevents.loop t with + (match Fsevents.RunLoop.run_current_thread runloop with | Error Exit -> print_endline "[EXIT]" | Error _ -> assert false | Ok () -> ()); - Fsevents.destroy t; + List.iter fsevents ~f:Fsevents.stop; finish ()) +let test_with_operations ?on_event ?exclusion_paths f = + test_with_multiple_fsevents ~test:f ~setup:(fun ~cwd config -> + let config = + match exclusion_paths with + | None -> config + | Some f -> { config with exclusion_paths = f cwd } + in + [ (match on_event with + | None -> config + | Some on_event -> { config with on_events = List.iter ~f:on_event }) + ]) + let%expect_test "file create event" = test_with_operations (fun () -> Io.String_path.write_file "./file" "foobar"); [%expect - {| > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/file" } |}] + {| + > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/file" } |}] let%expect_test "dir create event" = test_with_operations (fun () -> ignore (Fpath.mkdir "./blahblah")); [%expect - {| > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/blahblah" } |}] + {| + > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/blahblah" } |}] let%expect_test "move file" = test_with_operations (fun () -> @@ -179,10 +206,30 @@ let%expect_test "set exclusion paths" = (* absolute paths work *) run Filename.concat; [%expect - {| > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/ignored" } |}]; + {| + > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/ignored/old" } + > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/ignored" } |}]; (* but relative paths do not *) run (fun _ name -> name); [%expect {| > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/ignored/old" } > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/ignored" } |}] + +let%expect_test "multiple fsevents" = + test_with_multiple_fsevents + ~setup:(fun ~cwd config -> + let create path = + let dir = Filename.concat cwd path in + ignore (Fpath.mkdir dir); + { config with dir } + in + [ create "foo"; create "bar" ]) + ~test:(fun () -> + Io.String_path.write_file "foo/file" ""; + Io.String_path.write_file "bar/file" ""; + Io.String_path.write_file "xxx" "" (* this one is ignored *)); + [%expect + {| + > { action = "Create"; kind = "File"; path = "$TESTCASE_ROOT/foo/file" } + > { action = "Create"; kind = "File"; path = "$TESTCASE_ROOT/bar/file" } |}] diff --git a/test/expect-tests/fsevents/fsevents_tests.mli b/test/expect-tests/fsevents/fsevents_tests.mli new file mode 100644 index 000000000000..e69de29bb2d1 From a26cc9ddaebc6dcf9849075ae62e730c74906a56 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 2 Nov 2021 17:06:57 -0600 Subject: [PATCH 28/32] chore: add CHANGES entry for inotifywait Signed-off-by: Rudi Grinberg --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index b9d9f9fe9417..781b4124bf47 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,6 +4,9 @@ Unreleased - In watch mode, use fsevents instead of fswatch on OSX (#4937, #4990, fixes #4896 @rgrinberg) +- Remove `inotifywait` watch mode backend on Linux. We now use the inotify API + exclusively (#4941, @rgrinberg) + - Report cycles between virtual libraries and their implementation (#5050, fixes #2896, @rgrinberg) From ebd799739dd7bc1beb06acec7e89e00190195835 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Tue, 2 Nov 2021 23:45:48 +0000 Subject: [PATCH 29/32] Add a test for copy rules in file-watching mode (#5082) Another test for file-watching mode, and another subtle bug: copy rules don't seem to interact well with [promote-into]. I suspect the plain [promote] logic is broken too but it's masked by the fact that Dune sees the promoted files in the build directory. With the [into] option, the corresponding file is in a different directory and there is nothing to mask the bug. Signed-off-by: Andrey Mokhov --- .../test-cases/watching/copy-rules.t | 90 +++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 test/blackbox-tests/test-cases/watching/copy-rules.t diff --git a/test/blackbox-tests/test-cases/watching/copy-rules.t b/test/blackbox-tests/test-cases/watching/copy-rules.t new file mode 100644 index 000000000000..d4a601bbfc49 --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/copy-rules.t @@ -0,0 +1,90 @@ +Test rules that copy source files in file-watching mode. + + $ . ./helpers.sh + + $ echo '(lang dune 3.0)' > dune-project + $ cat > dune < (rule + > (deps (glob_files *.txt)) + > (target summary) + > (action (bash "cat %{deps} > %{target}"))) + > EOF + $ echo a > a.txt + + $ start_dune + + $ build summary + Success + $ cat _build/default/summary + a + +Add [b.txt] manually. Dune notices this. + + $ echo b > b.txt + $ build summary + Success + $ cat _build/default/summary + a + b + +Now add [c.txt] via a new rule. Note that we do not request [c.txt] to be built, +only [summary], but Dune still builds it. Presumably, this isn't a bug but a +consequence of using a glob in this directory, which forces all *.txt rules. + + $ cat > dune < (rule + > (deps (glob_files *.txt)) + > (target summary) + > (action (bash "cat %{deps} > %{target}"))) + > (rule + > (target c.txt) + > (action (write-file %{target} c))) + > EOF + + $ build summary + Success + $ cat _build/default/summary + a + b + c + +Now demonstrate a bug: Dune fails to notice that [d.txt] appears via promotion. + +# CR-someday amokhov: Fix this test. + + $ mkdir subdir + $ cat > subdir/dune < (rule + > (target d.txt) + > (mode (promote (into ..))) + > (action (write-file %{target} d))) + > EOF + $ build summary subdir/d.txt + Success + $ cat _build/default/summary + a + b + c + +Note that [d.txt] is here but [c.txt] isn't (it's not promoted). + + $ ls *.txt + a.txt + b.txt + d.txt + +We're done. + + $ stop_dune + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... From 78fa5d22c3cc09345bfe3eb25fb57e0cd7e3c4bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Wed, 3 Nov 2021 12:10:09 +0000 Subject: [PATCH 30/32] Surface Action.Full.t through the Super_context API (#5083) Super_context.add_rule used to create the Action.Full.t on the fly. This made it complicated to attach actions parameters such as locks or sandboxing configuration at the point the action was created. This PR changes Super_context.add_rule to take an Action.Full.t directly instead of an Action.t + the various other fields as argument. To make the code more natural, it also changes various functions such as Action_unexpanded.expand to return an Action.Full.t rather than an Action.t. Signed-off-by: Jeremie Dimino --- otherlibs/stdune-unstable/env.ml | 14 ++++++-- otherlibs/stdune-unstable/monoid.mli | 2 +- src/dune_engine/action.ml | 52 ++++++++++++++++++++++++---- src/dune_engine/action.mli | 19 ++++++++-- src/dune_engine/action_builder.ml | 27 ++++++++++----- src/dune_engine/action_builder.mli | 27 ++++++++++----- src/dune_engine/dep.ml | 12 ++++--- src/dune_rules/action_unexpanded.ml | 4 +-- src/dune_rules/action_unexpanded.mli | 4 +-- src/dune_rules/buildable_rules.ml | 2 +- src/dune_rules/cinaps.ml | 14 ++++---- src/dune_rules/command.ml | 4 +-- src/dune_rules/command.mli | 4 +-- src/dune_rules/coq_rules.ml | 4 +-- src/dune_rules/coq_rules.mli | 6 ++-- src/dune_rules/cram_rules.ml | 8 ++--- src/dune_rules/ctypes_rules.ml | 3 +- src/dune_rules/cxx_rules.ml | 2 +- src/dune_rules/format_rules.ml | 6 ++-- src/dune_rules/inline_tests.ml | 18 +++++----- src/dune_rules/jsoo_rules.mli | 2 +- src/dune_rules/mdx.ml | 2 +- src/dune_rules/menhir.ml | 4 +-- src/dune_rules/merlin.ml | 11 +++--- src/dune_rules/module_compilation.ml | 27 +++++++-------- src/dune_rules/ocamldep.ml | 5 ++- src/dune_rules/ocamlobjinfo.mli | 2 +- src/dune_rules/odoc.ml | 9 ++--- src/dune_rules/preprocessing.ml | 16 ++++----- src/dune_rules/preprocessing.mli | 2 +- src/dune_rules/simple_rules.ml | 43 ++++++++++++++--------- src/dune_rules/simple_rules.mli | 3 +- src/dune_rules/super_context.ml | 33 +++++++++--------- src/dune_rules/super_context.mli | 11 +++--- 34 files changed, 252 insertions(+), 150 deletions(-) diff --git a/otherlibs/stdune-unstable/env.ml b/otherlibs/stdune-unstable/env.ml index 4dde676213b0..e39959f1d921 100644 --- a/otherlibs/stdune-unstable/env.ml +++ b/otherlibs/stdune-unstable/env.ml @@ -77,9 +77,17 @@ let add t ~var ~value = make (Map.set t.vars var value) let remove t ~var = make (Map.remove t.vars var) -let extend t ~vars = make (Map.superpose t.vars vars) - -let extend_env x y = extend x ~vars:y.vars +let extend t ~vars = + if Map.is_empty vars then + t + else + make (Map.superpose t.vars vars) + +let extend_env x y = + if Map.is_empty x.vars then + y + else + extend x ~vars:y.vars let to_dyn t = let open Dyn.Encoder in diff --git a/otherlibs/stdune-unstable/monoid.mli b/otherlibs/stdune-unstable/monoid.mli index 02999799f266..22028226fcf8 100644 --- a/otherlibs/stdune-unstable/monoid.mli +++ b/otherlibs/stdune-unstable/monoid.mli @@ -5,7 +5,7 @@ module type S = Monoid_intf.S (** This functor extends the basic definition of a monoid by adding a convenient operator synonym [( @ ) = combine], as well as derived functions [reduce] and [map_reduce]. *) -module Make (M : Basic) : S with type t = M.t +module Make (M : Basic) : S with type t := M.t [@@inlined always] (** The monoid you get with [empty = false] and [combine = ( || )]. *) diff --git a/src/dune_engine/action.ml b/src/dune_engine/action.ml index d492d1e1ce7e..daf8ce235722 100644 --- a/src/dune_engine/action.ml +++ b/src/dune_engine/action.ml @@ -78,6 +78,20 @@ end include Action_ast.Make (Prog) (Dpath) (Dpath.Build) (String_with_sexp) (Ast) +include Monoid.Make (struct + type nonrec t = t + + let empty = Progn [] + + let combine a b = + match (a, b) with + | Progn [], x + | x, Progn [] -> + x + | Progn xs, Progn ys -> Progn (xs @ ys) + | x, y -> Progn [ x; y ] +end) + type string = String.t module For_shell = struct @@ -263,10 +277,36 @@ let is_useful_to_distribute = is_useful_to true false let is_useful_to_memoize = is_useful_to true true module Full = struct - type nonrec t = - { action : t - ; env : Env.t - ; locks : Path.t list - ; can_go_in_shared_cache : bool - } + module T = struct + type nonrec t = + { action : t + ; env : Env.t + ; locks : Path.t list + ; can_go_in_shared_cache : bool + } + + let empty = + { action = Progn [] + ; env = Env.empty + ; locks = [] + ; can_go_in_shared_cache = true + } + + let combine { action; env; locks; can_go_in_shared_cache } x = + { action = combine action x.action + ; env = Env.extend_env env x.env + ; locks = locks @ x.locks + ; can_go_in_shared_cache = + can_go_in_shared_cache && x.can_go_in_shared_cache + } + end + + include T + include Monoid.Make (T) + + let make ?(env = Env.empty) ?(locks = []) ?(can_go_in_shared_cache = true) + action = + { action; env; locks; can_go_in_shared_cache } + + let map t ~f = { t with action = f t.action } end diff --git a/src/dune_engine/action.mli b/src/dune_engine/action.mli index f8a9bb96188a..7b7becb2c4c8 100644 --- a/src/dune_engine/action.mli +++ b/src/dune_engine/action.mli @@ -65,6 +65,8 @@ include with type string := string with type t := t +include Monoid with type t := t + module For_shell : sig include Action_intf.Ast @@ -117,11 +119,24 @@ val is_useful_to_distribute : t -> is_useful val is_useful_to_memoize : t -> is_useful module Full : sig + type action := t + (** A full action with its environment and list of locks *) - type nonrec t = - { action : t + type t = + { action : action ; env : Env.t ; locks : Path.t list ; can_go_in_shared_cache : bool } + + val make : + ?env:Env.t (** default [Env.empty] *) + -> ?locks:Path.t list (** default [\[\]] *) + -> ?can_go_in_shared_cache:bool (** default [true] *) + -> action + -> t + + val map : t -> f:(action -> action) -> t + + include Monoid with type t := t end diff --git a/src/dune_engine/action_builder.ml b/src/dune_engine/action_builder.ml index a67eb90878de..b14ced71ea4d 100644 --- a/src/dune_engine/action_builder.ml +++ b/src/dune_engine/action_builder.ml @@ -172,6 +172,8 @@ module With_targets = struct module O = struct let ( >>> ) = seq + let ( >>| ) t f = map t ~f + let ( and+ ) = both let ( let+ ) a f = map ~f a @@ -193,7 +195,7 @@ module With_targets = struct let write_file_dyn ?(perm = Action.File_perm.Normal) fn s = add ~file_targets:[ fn ] (let+ s = s in - Action.Write_file (fn, perm, s)) + Action.Full.make (Action.Write_file (fn, perm, s))) let memoize name t = { build = memoize name t.build; targets = t.targets } end @@ -210,33 +212,40 @@ let with_no_targets build : _ With_targets.t = let write_file ?(perm = Action.File_perm.Normal) fn s = with_file_targets ~file_targets:[ fn ] - (return (Action.Write_file (fn, perm, s))) + (return (Action.Full.make (Action.Write_file (fn, perm, s)))) let write_file_dyn ?(perm = Action.File_perm.Normal) fn s = with_file_targets ~file_targets:[ fn ] (let+ s = s in - Action.Write_file (fn, perm, s)) + Action.Full.make (Action.Write_file (fn, perm, s))) + +let with_stdout_to ?(perm = Action.File_perm.Normal) fn t = + with_targets ~targets:(Targets.File.create fn) + (let+ (act : Action.Full.t) = t in + { act with action = Action.with_stdout_to ~perm fn act.action }) let copy ~src ~dst = with_file_targets ~file_targets:[ dst ] - (path src >>> return (Action.Copy (src, dst))) + (path src >>> return (Action.Full.make (Action.Copy (src, dst)))) let copy_and_add_line_directive ~src ~dst = with_file_targets ~file_targets:[ dst ] - (path src >>> return (Action.Copy_and_add_line_directive (src, dst))) + (path src + >>> return + (Action.Full.make (Action.Copy_and_add_line_directive (src, dst)))) let symlink ~src ~dst = with_file_targets ~file_targets:[ dst ] - (path src >>> return (Action.Symlink (src, dst))) + (path src >>> return (Action.Full.make (Action.Symlink (src, dst)))) let create_file ?(perm = Action.File_perm.Normal) fn = with_file_targets ~file_targets:[ fn ] - (return (Action.Redirect_out (Stdout, fn, perm, Action.empty))) + (return + (Action.Full.make (Action.Redirect_out (Stdout, fn, perm, Action.empty)))) let progn ts = let open With_targets.O in - let+ actions = With_targets.all ts in - Action.Progn actions + With_targets.all ts >>| Action.Full.reduce let dyn_memo_build_deps t = dyn_deps (dyn_memo_build t) diff --git a/src/dune_engine/action_builder.mli b/src/dune_engine/action_builder.mli index 05dfceaf6417..897b9a88f200 100644 --- a/src/dune_engine/action_builder.mli +++ b/src/dune_engine/action_builder.mli @@ -24,7 +24,7 @@ module With_targets : sig val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val write_file_dyn : - ?perm:Action.File_perm.t -> Path.Build.t -> string t -> Action.t t + ?perm:Action.File_perm.t -> Path.Build.t -> string t -> Action.Full.t t val all : 'a t list -> 'a list t @@ -35,6 +35,8 @@ module With_targets : sig module O : sig val ( >>> ) : unit t -> 'a t -> 'a t + val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t @@ -144,26 +146,35 @@ val if_file_exists : Path.t -> then_:'a t -> else_:'a t -> 'a t (** Create a file with the given contents. *) val write_file : - ?perm:Action.File_perm.t -> Path.Build.t -> string -> Action.t With_targets.t + ?perm:Action.File_perm.t + -> Path.Build.t + -> string + -> Action.Full.t With_targets.t val write_file_dyn : ?perm:Action.File_perm.t -> Path.Build.t -> string t - -> Action.t With_targets.t + -> Action.Full.t With_targets.t + +val with_stdout_to : + ?perm:Action.File_perm.t + -> Path.Build.t + -> Action.Full.t t + -> Action.Full.t With_targets.t -val copy : src:Path.t -> dst:Path.Build.t -> Action.t With_targets.t +val copy : src:Path.t -> dst:Path.Build.t -> Action.Full.t With_targets.t val copy_and_add_line_directive : - src:Path.t -> dst:Path.Build.t -> Action.t With_targets.t + src:Path.t -> dst:Path.Build.t -> Action.Full.t With_targets.t -val symlink : src:Path.t -> dst:Path.Build.t -> Action.t With_targets.t +val symlink : src:Path.t -> dst:Path.Build.t -> Action.Full.t With_targets.t val create_file : - ?perm:Action.File_perm.t -> Path.Build.t -> Action.t With_targets.t + ?perm:Action.File_perm.t -> Path.Build.t -> Action.Full.t With_targets.t (** Merge a list of actions accumulating the sets of their targets. *) -val progn : Action.t With_targets.t list -> Action.t With_targets.t +val progn : Action.Full.t With_targets.t list -> Action.Full.t With_targets.t (** A version of [dyn_memo_build] that makes it convenient to declare dynamic action dependencies. *) diff --git a/src/dune_engine/dep.ml b/src/dune_engine/dep.ml index 05813988f3a3..4384d02c30b1 100644 --- a/src/dune_engine/dep.ml +++ b/src/dune_engine/dep.ml @@ -342,13 +342,17 @@ end module Set = struct include O.Map - module T = Monoid.Make (struct + module T = struct type t = unit Map.t - let empty = empty + include Monoid.Make (struct + type nonrec t = t - let combine = union ~f:(fun _ () () -> Some ()) - end) + let empty = empty + + let combine = union ~f:(fun _ () () -> Some ()) + end) + end include T diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index a48c37e548f4..add0045149ab 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -508,7 +508,7 @@ let expand_no_targets t ~loc ~deps:deps_written_by_user ~expander ~what = let+ () = deps_builder and+ action = build in let dir = Path.build (Expander.dir expander) in - Action.Chdir (dir, action) + Action.Full.make (Action.Chdir (dir, action)) let expand t ~loc ~deps:deps_written_by_user ~targets_dir ~targets:targets_written_by_user ~expander = @@ -565,7 +565,7 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir let+ () = deps_builder and+ action = build in let dir = Path.build (Expander.dir expander) in - Action.Chdir (dir, action) + Action.Full.make (Action.Chdir (dir, action)) in Action_builder.with_targets ~targets build diff --git a/src/dune_rules/action_unexpanded.mli b/src/dune_rules/action_unexpanded.mli index 27a9e030c85f..1f807515e8c8 100644 --- a/src/dune_rules/action_unexpanded.mli +++ b/src/dune_rules/action_unexpanded.mli @@ -33,7 +33,7 @@ val expand : -> targets_dir:Path.Build.t -> targets:Path.Build.t Targets_spec.t -> expander:Expander.t - -> Action.t Action_builder.With_targets.t Memo.Build.t + -> Action.Full.t Action_builder.With_targets.t Memo.Build.t (** [what] as the same meaning as the argument of [Expander.Expanding_what.User_action_without_targets] *) @@ -43,4 +43,4 @@ val expand_no_targets : -> deps:Dep_conf.t Bindings.t -> expander:Expander.t -> what:string - -> Action.t Action_builder.t + -> Action.Full.t Action_builder.t diff --git a/src/dune_rules/buildable_rules.ml b/src/dune_rules/buildable_rules.ml index f976dba58c81..1981a81f3b2f 100644 --- a/src/dune_rules/buildable_rules.ml +++ b/src/dune_rules/buildable_rules.ml @@ -13,7 +13,7 @@ let gen_select_rules t ~dir compile_info = let* src_fn = Resolve.read src_fn in let src = Path.build (Path.Build.relative dir src_fn) in let+ () = Action_builder.path src in - Action.Copy_and_add_line_directive (src, dst)))) + Action.Full.make (Action.Copy_and_add_line_directive (src, dst))))) let with_lib_deps (t : Context.t) compile_info ~dir ~f = let prefix = diff --git a/src/dune_rules/cinaps.ml b/src/dune_rules/cinaps.ml index 86907305de2e..bec545d98381 100644 --- a/src/dune_rules/cinaps.ml +++ b/src/dune_rules/cinaps.ml @@ -128,12 +128,14 @@ let gen_rules sctx t ~dir ~scope = let module A = Action in let cinaps_exe = Path.build cinaps_exe in let+ () = Action_builder.path cinaps_exe in - A.chdir (Path.build dir) - (A.progn - (A.run (Ok cinaps_exe) [ "-diff-cmd"; "-" ] - :: List.map cinapsed_files ~f:(fun fn -> - A.diff ~optional:true (Path.build fn) - (Path.Build.extend_basename fn ~suffix:".cinaps-corrected")))) + Action.Full.make + @@ A.chdir (Path.build dir) + (A.progn + (A.run (Ok cinaps_exe) [ "-diff-cmd"; "-" ] + :: List.map cinapsed_files ~f:(fun fn -> + A.diff ~optional:true (Path.build fn) + (Path.Build.extend_basename fn ~suffix:".cinaps-corrected")) + )) in let cinaps_alias = alias ~dir in let* () = diff --git a/src/dune_rules/command.ml b/src/dune_rules/command.ml index 60b2caff4f71..1ae4f6320b00 100644 --- a/src/dune_rules/command.ml +++ b/src/dune_rules/command.ml @@ -110,13 +110,13 @@ let run ~dir ?stdout_to prog args = | None -> action | Some path -> Action.with_stdout_to path action in - Action.chdir dir action) + Action.Full.make (Action.chdir dir action)) let run' ~dir prog args = let open Action_builder.O in let+ () = dep_prog prog and+ args = expand_no_targets ~dir (S args) in - Action.chdir dir (Action.run prog args) + Action.Full.make (Action.chdir dir (Action.run prog args)) let quote_args = let rec loop quote = function diff --git a/src/dune_rules/command.mli b/src/dune_rules/command.mli index 4d1f84ca9e5d..660b33ad222e 100644 --- a/src/dune_rules/command.mli +++ b/src/dune_rules/command.mli @@ -85,14 +85,14 @@ val run : -> ?stdout_to:Path.Build.t -> Action.Prog.t -> Args.any Args.t list - -> Action.t Action_builder.With_targets.t + -> Action.Full.t Action_builder.With_targets.t (** Same as [run], but for actions that don't produce targets *) val run' : dir:Path.t -> Action.Prog.t -> Args.without_targets Args.t list - -> Action.t Action_builder.t + -> Action.Full.t Action_builder.t (** [quote_args quote args] is [As \[quote; arg1; quote; arg2; ...\]] *) val quote_args : string -> string list -> _ Args.t diff --git a/src/dune_rules/coq_rules.ml b/src/dune_rules/coq_rules.ml index 288cedf44a0d..5122046a9b6b 100644 --- a/src/dune_rules/coq_rules.ml +++ b/src/dune_rules/coq_rules.ml @@ -389,8 +389,8 @@ let coqc_rule (cctx : _ Context.t) ~file_flags coq_module = module Module_rule = struct type t = - { coqdep : Action.t Action_builder.With_targets.t - ; coqc : Action.t Action_builder.With_targets.t + { coqdep : Action.Full.t Action_builder.With_targets.t + ; coqc : Action.Full.t Action_builder.With_targets.t } end diff --git a/src/dune_rules/coq_rules.mli b/src/dune_rules/coq_rules.mli index dcdf2f9e3a28..e66f86c3aeae 100644 --- a/src/dune_rules/coq_rules.mli +++ b/src/dune_rules/coq_rules.mli @@ -15,7 +15,7 @@ val setup_rules : -> dir:Path.Build.t -> dir_contents:Dir_contents.t -> Theory.t - -> Action.t Action_builder.With_targets.t list Memo.Build.t + -> Action.Full.t Action_builder.With_targets.t list Memo.Build.t val install_rules : sctx:Super_context.t @@ -27,11 +27,11 @@ val coqpp_rules : sctx:Super_context.t -> dir:Path.Build.t -> Coqpp.t - -> Action.t Action_builder.With_targets.t list Memo.Build.t + -> Action.Full.t Action_builder.With_targets.t list Memo.Build.t val extraction_rules : sctx:Super_context.t -> dir:Path.Build.t -> dir_contents:Dir_contents.t -> Extraction.t - -> Action.t Action_builder.With_targets.t list Memo.Build.t + -> Action.Full.t Action_builder.With_targets.t list Memo.Build.t diff --git a/src/dune_rules/cram_rules.ml b/src/dune_rules/cram_rules.ml index e83389827a02..b5f1ee4200d5 100644 --- a/src/dune_rules/cram_rules.ml +++ b/src/dune_rules/cram_rules.ml @@ -51,7 +51,7 @@ let test_rule ~sctx ~expander ~dir (spec : effective) | Error (Missing_run_t test) -> (* We error out on invalid tests even if they are disabled. *) Memo.Build.parallel_iter aliases ~f:(fun alias -> - Alias_rules.add sctx ~alias ~loc ~locks:[] (missing_run_t test)) + Alias_rules.add sctx ~alias ~loc (missing_run_t test)) | Ok test -> ( match enabled with | false -> @@ -73,6 +73,7 @@ let test_rule ~sctx ~expander ~dir (spec : effective) } ] in + let locks = Path.Set.to_list spec.locks in let cram = let open Action_builder.O in let+ () = Action_builder.path (Path.build script) @@ -87,11 +88,10 @@ let test_rule ~sctx ~expander ~dir (spec : effective) Action_builder.dep (Dep.sandbox_config Sandbox_config.needs_sandboxing) in - action + Action.Full.make action ~locks in - let locks = Path.Set.to_list spec.locks in Memo.Build.parallel_iter aliases ~f:(fun alias -> - Alias_rules.add sctx ~alias ~loc cram ~locks)) + Alias_rules.add sctx ~alias ~loc cram)) let rules ~sctx ~expander ~dir tests = let stanzas = diff --git a/src/dune_rules/ctypes_rules.ml b/src/dune_rules/ctypes_rules.ml index 3e76528cba79..74205f32e1cc 100644 --- a/src/dune_rules/ctypes_rules.ml +++ b/src/dune_rules/ctypes_rules.ml @@ -389,7 +389,8 @@ let build_c_program ~sctx ~dir ~source_files ~scope ~cflags_sexp ~output () = Action_builder.with_file_targets action ~file_targets:[ Path.Build.relative dir output ] in - Super_context.add_rule sctx ~dir build + Super_context.add_rule sctx ~dir + (Action_builder.With_targets.map ~f:Action.Full.make build) let cctx_with_substitutions ?(libraries = []) ~modules ~dir ~loc ~scope ~cctx () = diff --git a/src/dune_rules/cxx_rules.ml b/src/dune_rules/cxx_rules.ml index 81b0340c6014..843aab4a0559 100644 --- a/src/dune_rules/cxx_rules.ml +++ b/src/dune_rules/cxx_rules.ml @@ -40,6 +40,6 @@ let rules ~sctx ~dir = let+ run_preprocessor = Command.run ~dir:(Path.build dir) ~stdout_to:file prog args in - Action.progn [ write_test_file; run_preprocessor ] + Action.Full.reduce [ Action.Full.make write_test_file; run_preprocessor ] in Super_context.add_rule sctx ~dir action diff --git a/src/dune_rules/format_rules.ml b/src/dune_rules/format_rules.ml index 846a78f4679e..8dc979bbc90b 100644 --- a/src/dune_rules/format_rules.ml +++ b/src/dune_rules/format_rules.ml @@ -4,9 +4,9 @@ open Import let add_diff sctx loc alias ~dir ~input ~output = let open Action_builder.O in let action = Action.Chdir (Path.build dir, Action.diff input output) in - Super_context.add_alias_action sctx alias ~dir ~loc:(Some loc) ~locks:[] + Super_context.add_alias_action sctx alias ~dir ~loc:(Some loc) (Action_builder.paths [ input; Path.build output ] - >>> Action_builder.return action) + >>> Action_builder.return (Action.Full.make action)) let rec subdirs_until_root dir = match Path.parent dir with @@ -41,7 +41,7 @@ let gen_rules_output sctx (config : Format_config.t) ~version ~dialects @@ let open Action_builder.O in let+ () = Action_builder.path input in - Action.format_dune_file ~version input output + Action.Full.make (Action.format_dune_file ~version input output) | _ -> let ext = Path.Source.extension file in let open Option.O in diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index b093ca0f47af..c28724b93036 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -147,7 +147,8 @@ include Sub_system.Register_end_point (struct Action_unexpanded.expand_no_targets action ~loc ~expander ~deps:[] ~what:"inline test generators")))) in - Action.with_stdout_to target (Action.progn actions) + Action.Full.reduce actions + |> Action.Full.map ~f:(Action.with_stdout_to target) in Action_builder.With_targets.add ~file_targets:[ target ] action) and* cctx = @@ -250,13 +251,14 @@ include Sub_system.Register_end_point (struct | Ok p -> Action_builder.path p >>> Action_builder.return action) in let run_tests = Action.chdir (Path.build dir) action in - Action.progn - (run_tests - :: List.map source_files ~f:(fun fn -> - Action.diff ~optional:true fn - (Path.Build.extend_basename - (Path.as_in_build_dir_exn fn) - ~suffix:".corrected"))))) + Action.Full.make + @@ Action.progn + (run_tests + :: List.map source_files ~f:(fun fn -> + Action.diff ~optional:true fn + (Path.Build.extend_basename + (Path.as_in_build_dir_exn fn) + ~suffix:".corrected"))))) let gen_rules c ~(info : Info.t) ~backends = let open Memo.Build.O in diff --git a/src/dune_rules/jsoo_rules.mli b/src/dune_rules/jsoo_rules.mli index a2beae178990..ba57145ed74d 100644 --- a/src/dune_rules/jsoo_rules.mli +++ b/src/dune_rules/jsoo_rules.mli @@ -9,7 +9,7 @@ val build_cm : -> js_of_ocaml:Dune_file.Js_of_ocaml.t -> src:Path.Build.t -> target:Path.Build.t - -> Action.t Action_builder.With_targets.t Memo.Build.t option + -> Action.Full.t Action_builder.With_targets.t Memo.Build.t option val build_exe : Compilation_context.t diff --git a/src/dune_rules/mdx.ml b/src/dune_rules/mdx.ml index 3aaba42ecd35..73510d6a6499 100644 --- a/src/dune_rules/mdx.ml +++ b/src/dune_rules/mdx.ml @@ -28,7 +28,7 @@ module Files = struct let open Action_builder.O in let+ () = Action_builder.path src and+ () = Action_builder.path (Path.build corrected) in - Action.diff ~optional:false src corrected + Action.Full.make (Action.diff ~optional:false src corrected) end module Deps = struct diff --git a/src/dune_rules/menhir.ml b/src/dune_rules/menhir.ml index 19952e4f91c3..22206f8a8d84 100644 --- a/src/dune_rules/menhir.ml +++ b/src/dune_rules/menhir.ml @@ -112,12 +112,12 @@ module Run (P : PARAMS) = struct (* [menhir args] generates a Menhir command line (a build action). *) let menhir (args : 'a args) : - Action.t Action_builder.With_targets.t Memo.Build.t = + Action.Full.t Action_builder.With_targets.t Memo.Build.t = Memo.Build.map menhir_binary ~f:(fun prog -> Command.run ~dir:(Path.build build_dir) prog args) let rule ?(mode = stanza.mode) : - Action.t Action_builder.With_targets.t -> unit Memo.Build.t = + Action.Full.t Action_builder.With_targets.t -> unit Memo.Build.t = SC.add_rule sctx ~dir ~mode ~loc:stanza.loc let expand_flags flags = Super_context.menhir_flags sctx ~dir ~expander ~flags diff --git a/src/dune_rules/merlin.ml b/src/dune_rules/merlin.ml index b38010a39a80..57f93c59a2c9 100644 --- a/src/dune_rules/merlin.ml +++ b/src/dune_rules/merlin.ml @@ -293,11 +293,12 @@ module Unprocessed = struct in Some Processed.{ flag = "-pp"; args } in - Action_builder.map action ~f:(function - | Run (exe, args) -> pp_of_action exe args - | Chdir (_, Run (exe, args)) -> pp_of_action exe args - | Chdir (_, Chdir (_, Run (exe, args))) -> pp_of_action exe args - | _ -> None)) + Action_builder.map action ~f:(fun act -> + match act.action with + | Run (exe, args) -> pp_of_action exe args + | Chdir (_, Run (exe, args)) -> pp_of_action exe args + | Chdir (_, Chdir (_, Run (exe, args))) -> pp_of_action exe args + | _ -> None)) | _ -> Action_builder.return None let pp_flags sctx ~expander libname preprocess : diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index ce685c4a2aa8..5ca906edf952 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -271,20 +271,19 @@ let ocamlc_i ?(flags = []) ~deps cctx (m : Module.t) ~output = (Action_builder.With_targets.add ~file_targets:[ output ] (let open Action_builder.With_targets.O in Action_builder.with_no_targets cm_deps - >>> Action_builder.With_targets.map - ~f:(Action.with_stdout_to output) - (Command.run (Ok ctx.ocamlc) ~dir:(Path.build ctx.build_dir) - [ Command.Args.dyn ocaml_flags - ; A "-I" - ; Path (Path.build (Obj_dir.byte_dir obj_dir)) - ; Command.Args.as_any (Cm_kind.Dict.get (CC.includes cctx) Cmo) - ; opens modules m - ; As flags - ; A "-short-paths" - ; A "-i" - ; Command.Ml_kind.flag Impl - ; Dep src - ]))) + >>> Command.run (Ok ctx.ocamlc) ~dir:(Path.build ctx.build_dir) + ~stdout_to:output + [ Command.Args.dyn ocaml_flags + ; A "-I" + ; Path (Path.build (Obj_dir.byte_dir obj_dir)) + ; Command.Args.as_any (Cm_kind.Dict.get (CC.includes cctx) Cmo) + ; opens modules m + ; As flags + ; A "-short-paths" + ; A "-i" + ; Command.Ml_kind.flag Impl + ; Dep src + ])) (* The alias module is an implementation detail to support wrapping library modules under a single toplevel name. Since OCaml doesn't have proper support diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index fdd1255ea79f..1b401b307153 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -123,7 +123,10 @@ let deps_of ~cctx ~ml_kind unit = in Action.Merge_files_into (sources, extras, all_deps_file)) in - let+ () = SC.add_rule sctx ~dir action in + let+ () = + SC.add_rule sctx ~dir + (Action_builder.With_targets.map ~f:Action.Full.make action) + in let all_deps_file = Path.build all_deps_file in Action_builder.memoize (Path.to_string all_deps_file) diff --git a/src/dune_rules/ocamlobjinfo.mli b/src/dune_rules/ocamlobjinfo.mli index 220890d17b45..3d05118c5437 100644 --- a/src/dune_rules/ocamlobjinfo.mli +++ b/src/dune_rules/ocamlobjinfo.mli @@ -11,7 +11,7 @@ val rules : dir:Path.Build.t -> ctx:Context.t -> unit:Path.t - -> Action.t Action_builder.With_targets.t * t Action_builder.t + -> Action.Full.t Action_builder.With_targets.t * t Action_builder.t (** For testing only *) val parse : string -> t diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index 4a8289f4a3d0..94a9dc66f3a1 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -274,10 +274,11 @@ let setup_html sctx (odoc_file : odoc) ~pkg ~requires = >>> Action_builder.progn (Action_builder.with_no_targets (Action_builder.return - (Action.Progn - [ Action.Remove_tree to_remove - ; Action.Mkdir (Path.build odoc_file.html_dir) - ])) + (Action.Full.make + (Action.Progn + [ Action.Remove_tree to_remove + ; Action.Mkdir (Path.build odoc_file.html_dir) + ]))) :: Command.run ~dir:(Path.build (Paths.html_root ctx)) odoc diff --git a/src/dune_rules/preprocessing.ml b/src/dune_rules/preprocessing.ml index d5f5e1d94724..be25df549272 100644 --- a/src/dune_rules/preprocessing.ml +++ b/src/dune_rules/preprocessing.ml @@ -472,10 +472,11 @@ let workspace_root_var = let promote_correction fn build ~suffix = let open Action_builder.O in let+ act = build in - Action.progn + Action.Full.reduce [ act - ; Action.diff ~optional:true (Path.build fn) - (Path.Build.extend_basename fn ~suffix) + ; Action.Full.make + (Action.diff ~optional:true (Path.build fn) + (Path.Build.extend_basename fn ~suffix)) ] let promote_correction_with_target fn build ~suffix = @@ -483,8 +484,9 @@ let promote_correction_with_target fn build ~suffix = [ build ; Action_builder.with_no_targets (Action_builder.return - (Action.diff ~optional:true (Path.build fn) - (Path.Build.extend_basename fn ~suffix))) + (Action.Full.make + (Action.diff ~optional:true (Path.build fn) + (Path.Build.extend_basename fn ~suffix)))) ] let chdir action = Action_unexpanded.Chdir (workspace_root_var, action) @@ -502,9 +504,7 @@ let action_for_pp ~loc ~expander ~action ~src = let action_for_pp_with_target ~loc ~expander ~action ~src ~target = let action = action_for_pp ~loc ~expander ~action ~src in - Action_builder.With_targets.map - ~f:(Action.with_stdout_to target) - (Action_builder.with_file_targets ~file_targets:[ target ] action) + Action_builder.with_stdout_to target action (* Generate rules for the dialect modules in [modules] and return a a new module with only OCaml sources *) diff --git a/src/dune_rules/preprocessing.mli b/src/dune_rules/preprocessing.mli index a4f3fe65cabf..0a7ec1c56b60 100644 --- a/src/dune_rules/preprocessing.mli +++ b/src/dune_rules/preprocessing.mli @@ -37,7 +37,7 @@ val action_for_pp_with_target : -> action:Action_unexpanded.t -> src:Path.Build.t -> target:Path.Build.t - -> Action.t Action_builder.With_targets.t + -> Action.Full.t Action_builder.With_targets.t val ppx_exe : Super_context.t -> scope:Scope.t -> Lib_name.t -> Path.Build.t Resolve.Build.t diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index a4906c38b91c..d541daa2c9a1 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -6,19 +6,15 @@ module SC = Super_context open Memo.Build.O module Alias_rules = struct - let add sctx ~alias ~loc ~locks ?patch_back_source_tree build = + let add sctx ~alias ~loc ?patch_back_source_tree build = let dir = Alias.dir alias in - SC.add_alias_action sctx alias ~dir ~loc ~locks ?patch_back_source_tree - build + SC.add_alias_action sctx alias ~dir ~loc ?patch_back_source_tree build let add_empty sctx ~loc ~alias = - let action = Action_builder.return Action.empty in - add sctx ~loc ~alias action ~locks:[] + let action = Action_builder.return (Action.Full.make Action.empty) in + add sctx ~loc ~alias action end -let interpret_locks ~expander = - Memo.Build.List.map ~f:(Expander.No_deps.expand_path expander) - let check_filename ~kind = let not_in_dir ~error_loc s = User_error.raise ~loc:error_loc @@ -48,8 +44,7 @@ type rule_kind = | Alias_with_targets of Alias.Name.t * Path.Build.t | No_alias -let rule_kind ~(rule : Rule.t) - ~(action : Action.t Action_builder.With_targets.t) = +let rule_kind ~(rule : Rule.t) ~(action : _ Action_builder.With_targets.t) = match rule.alias with | None -> No_alias | Some alias -> ( @@ -57,15 +52,28 @@ let rule_kind ~(rule : Rule.t) | None -> Alias_only alias | Some target -> Alias_with_targets (alias, target)) -let add_user_rule sctx ~dir ~(rule : Rule.t) ~action ~expander = - let* locks = interpret_locks ~expander rule.locks in +let interpret_and_add_locks ~expander locks action = + let+ locks = + Memo.Build.List.map locks ~f:(Expander.No_deps.expand_path expander) + in + match locks with + | [] -> action + | _ -> + let open Action_builder.O in + let+ (act : Action.Full.t) = action in + { act with locks } + +let add_user_rule sctx ~dir ~(rule : Rule.t) + ~(action : _ Action_builder.With_targets.t) ~expander = + let* build = interpret_and_add_locks ~expander rule.locks action.build in + let action = { action with Action_builder.With_targets.build } in SC.add_rule_get_targets sctx (* user rules may have extra requirements, in which case they will be specified as a part of rule.deps, which will be correctly taken care of by the action builder *) ~sandbox:Sandbox_config.no_special_requirements ~dir ~mode:rule.mode - ~loc:rule.loc ~locks action + ~loc:rule.loc action let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = Expander.eval_blang expander rule.enabled_if >>= function @@ -117,14 +125,14 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = targets | Alias_only name -> let alias = Alias.make ~dir name in - let* locks = interpret_locks ~expander rule.locks in + let* action = interpret_and_add_locks ~expander rule.locks action.build in let patch_back_source_tree = match rule.mode with | Patch_back_source_tree -> true | _ -> false in let+ () = - Alias_rules.add sctx ~alias ~loc:(Some rule.loc) action.build ~locks + Alias_rules.add sctx ~alias ~loc:(Some rule.loc) action ~patch_back_source_tree in Targets.empty) @@ -198,6 +206,7 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = Action_builder.copy) ~src:file_src ~dst:file_dst)) in + let targets = Path.Set.map files ~f:(fun file_src -> let basename = Path.basename file_src in @@ -227,7 +236,6 @@ let alias sctx ?extra_bindings ~dir ~expander (alias_conf : Alias_conf.t) = let builder, _expander = Dep_conf_eval.named ~expander alias_conf.deps in Rules.Produce.Alias.add_deps alias ?loc builder | Some (action_loc, action) -> - let* locks = interpret_locks ~expander alias_conf.locks in let action = let builder, expander = Dep_conf_eval.named ~expander alias_conf.deps in let open Action_builder.O in @@ -243,4 +251,5 @@ let alias sctx ?extra_bindings ~dir ~expander (alias_conf : Alias_conf.t) = in action in - Alias_rules.add sctx ~loc ~locks action ~alias) + let* action = interpret_and_add_locks ~expander alias_conf.locks action in + Alias_rules.add sctx ~loc action ~alias) diff --git a/src/dune_rules/simple_rules.mli b/src/dune_rules/simple_rules.mli index 9d69193d737c..edef1aca1acc 100644 --- a/src/dune_rules/simple_rules.mli +++ b/src/dune_rules/simple_rules.mli @@ -10,9 +10,8 @@ module Alias_rules : sig Super_context.t -> alias:Alias.t -> loc:Loc.t option - -> locks:Path.t list -> ?patch_back_source_tree:bool - -> Action.t Action_builder.t + -> Action.Full.t Action_builder.t -> unit Memo.Build.t val add_empty : diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index 6b2c77fbfaa7..6f3f6baaa76a 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -312,43 +312,44 @@ let get_node t = Env_tree.get_node t open Memo.Build.O -let make_full_action t ~dir ~locks build = +let extend_action t ~dir build = let open Action_builder.O in - let+ (action : Action.t) = build + let+ (act : Action.Full.t) = build and+ env = Action_builder.memo_build (let open Memo.Build.O in get_node t.env_tree ~dir >>= Env_node.external_env) in - let action = - match action with - | Chdir _ -> action - | _ -> Chdir (Path.build t.context.build_dir, action) + let action : Action.t = + match act.action with + | Chdir _ -> act.action + | _ -> Chdir (Path.build t.context.build_dir, act.action) in - { Action.Full.action; env; locks; can_go_in_shared_cache = true } + let env = Env.extend_env env act.env in + { act with env; action } -let make_rule t ?sandbox ?mode ?(locks = []) ?loc ~dir +let make_rule t ?sandbox ?mode ?loc ~dir { Action_builder.With_targets.build; targets } = - let build = make_full_action t build ~locks ~dir in + let build = extend_action t build ~dir in Rule.make ?sandbox ?mode ~info:(Rule.Info.of_loc_opt loc) ~context:(Some (Context.build_context t.context)) ~targets build -let add_rule t ?sandbox ?mode ?locks ?loc ~dir build = - let rule = make_rule t ?sandbox ?mode ?locks ?loc ~dir build in +let add_rule t ?sandbox ?mode ?loc ~dir build = + let rule = make_rule t ?sandbox ?mode ?loc ~dir build in Rules.Produce.rule rule -let add_rule_get_targets t ?sandbox ?mode ?locks ?loc ~dir build = - let rule = make_rule t ?sandbox ?mode ?locks ?loc ~dir build in +let add_rule_get_targets t ?sandbox ?mode ?loc ~dir build = + let rule = make_rule t ?sandbox ?mode ?loc ~dir build in let+ () = Rules.Produce.rule rule in rule.targets let add_rules t ?sandbox ~dir builds = Memo.Build.parallel_iter builds ~f:(add_rule t ?sandbox ~dir) -let add_alias_action t alias ~dir ~loc ?(locks = []) - ?(patch_back_source_tree = false) action = - let build = make_full_action t action ~locks ~dir in +let add_alias_action t alias ~dir ~loc ?(patch_back_source_tree = false) action + = + let build = extend_action t action ~dir in Rules.Produce.Alias.add_action ~context:(Context.build_context t.context) alias ~loc ~patch_back_source_tree build diff --git a/src/dune_rules/super_context.mli b/src/dune_rules/super_context.mli index f05daee90eda..7c1beaa1fb06 100644 --- a/src/dune_rules/super_context.mli +++ b/src/dune_rules/super_context.mli @@ -108,27 +108,25 @@ val add_rule : t -> ?sandbox:Sandbox_config.t -> ?mode:Rule.Mode.t - -> ?locks:Path.t list -> ?loc:Loc.t -> dir:Path.Build.t - -> Action.t Action_builder.With_targets.t + -> Action.Full.t Action_builder.With_targets.t -> unit Memo.Build.t val add_rule_get_targets : t -> ?sandbox:Sandbox_config.t -> ?mode:Rule.Mode.t - -> ?locks:Path.t list -> ?loc:Loc.t -> dir:Path.Build.t - -> Action.t Action_builder.With_targets.t + -> Action.Full.t Action_builder.With_targets.t -> Targets.t Memo.Build.t val add_rules : t -> ?sandbox:Sandbox_config.t -> dir:Path.Build.t - -> Action.t Action_builder.With_targets.t list + -> Action.Full.t Action_builder.With_targets.t list -> unit Memo.Build.t val add_alias_action : @@ -136,9 +134,8 @@ val add_alias_action : -> Alias.t -> dir:Path.Build.t -> loc:Loc.t option - -> ?locks:Path.t list -> ?patch_back_source_tree:bool - -> Action.t Action_builder.t + -> Action.Full.t Action_builder.t -> unit Memo.Build.t (** [resolve_program t ?hint name] resolves a program. [name] is looked up in From 8ef59e4648abf2ff1f042136ad767f22dd31b93c Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 3 Nov 2021 14:19:28 +0000 Subject: [PATCH 31/32] Print --debug-cache messages without --verbose (#5084) Signed-off-by: Andrey Mokhov --- src/dune_engine/build_system.ml | 26 ++++++------ src/dune_engine/fs_memo.ml | 7 ++-- .../test-cases/dune-cache/mode-copy.t/run.t | 42 +++++++++---------- .../dune-cache/mode-hardlink.t/run.t | 42 +++++++++---------- .../test-cases/watching/test-1.t/run.t | 1 - 5 files changed, 58 insertions(+), 60 deletions(-) diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 498d8478b5fb..e0deee357e71 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -1600,12 +1600,13 @@ end = struct | `Always_rerun -> "not trying to use the cache" | `Dynamic_deps_changed -> "dynamic dependencies changed" in - Log.info - [ Pp.hbox - (Pp.textf "Workspace-local cache miss: %s: %s\n" - (Path.Build.to_string head_target) - reason) - ] + Console.print_user_message + (User_message.make + [ Pp.hbox + (Pp.textf "Workspace-local cache miss: %s: %s" + (Path.Build.to_string head_target) + reason) + ]) let report_shared_cache_miss ~(cache_debug_flags : Cache_debug_flags.t) ~rule_digest ~head_target (reason : Shared_cache_miss_reason.t) = @@ -1630,12 +1631,13 @@ end = struct "rerunning for reproducibility check" | Not_found_in_cache -> "not found in cache" in - Log.info - [ Pp.hbox - (Pp.textf "Shared cache miss %s: %s\n" - (shared_cache_key_string_for_log ~rule_digest ~head_target) - reason) - ] + Console.print_user_message + (User_message.make + [ Pp.hbox + (Pp.textf "Shared cache miss %s: %s" + (shared_cache_key_string_for_log ~rule_digest ~head_target) + reason) + ]) let execute_rule_impl ~rule_kind rule = let t = t () in diff --git a/src/dune_engine/fs_memo.ml b/src/dune_engine/fs_memo.ml index 4e758ccab1d4..a89c62df7476 100644 --- a/src/dune_engine/fs_memo.ml +++ b/src/dune_engine/fs_memo.ml @@ -86,9 +86,10 @@ let update_all : Path.t -> Fs_cache.Update_result.t = if !Clflags.debug_fs_cache then Console.print_user_message (User_message.make - [ Pp.textf "Updating %s cache for %S: %s" (Fs_cache.Debug.name t) - (Path.to_string path) - (Dyn.to_string (Fs_cache.Update_result.to_dyn result)) + [ Pp.hbox + (Pp.textf "Updating %s cache for %S: %s" (Fs_cache.Debug.name t) + (Path.to_string path) + (Dyn.to_string (Fs_cache.Update_result.to_dyn result))) ]); result in diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t index 16d11e951a70..39a0ffe60cf2 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t @@ -30,7 +30,16 @@ It's a duck. It quacks. (Yes, the author of this comment didn't get it.) Test that after the build, the files in the build directory have the hard link count of 1, because they are not shared with the corresponding cache entries. - $ dune build --config-file=config target1 --debug-cache=shared,workspace-local +We expect to see both workspace-local and shared cache misses, because we've +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 [8b39c1a0b45579f8da18f42be8e6aca0] (_build/default/source): not found in cache + Workspace-local cache miss: _build/default/target1: never seen this target before + Shared cache miss [fccfd1af13c64ce19b45e2a76fb8132c] (_build/default/target1): not found in cache + $ dune_cmd stat hardlinks _build/default/source 1 $ dune_cmd stat hardlinks _build/default/target1 @@ -40,19 +49,17 @@ count of 1, because they are not shared with the corresponding cache entries. $ dune_cmd exists _build/default/beacon true -We expect to see both workspace-local and shared cache misses in the build log, -because we've never built [target1] before. - - $ cat _build/log | grep '_build/default/source\|_build/default/target' - # Workspace-local cache miss: _build/default/source: never seen this target before - # Shared cache miss [8b39c1a0b45579f8da18f42be8e6aca0] (_build/default/source): not found in cache - # Workspace-local cache miss: _build/default/target1: never seen this target before - # Shared cache miss [fccfd1af13c64ce19b45e2a76fb8132c] (_build/default/target1): not found in cache - Test that rebuilding works. +Now we expect to see only workspace-local cache misses, because we've cleaned +[_build/default] but not the shared cache. + $ rm -rf _build/default - $ dune build --config-file=config target1 --debug-cache=shared,workspace-local + $ 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: target missing from build dir + Workspace-local cache miss: _build/default/target1: target missing from build dir + $ dune_cmd stat hardlinks _build/default/source 1 $ dune_cmd stat hardlinks _build/default/target1 @@ -69,19 +76,10 @@ Test that rebuilding works. \_o< COIN \_o< COIN -Now we expect to see only workspace-local cache misses in the build log, because -we've cleaned [_build/default] but not the shared cache. - - $ cat _build/log | grep '_build/default/source\|_build/default/target' - # Workspace-local cache miss: _build/default/source: target missing from build dir - # (_build/default/source) - # Workspace-local cache miss: _build/default/target1: target missing from build dir - # (_build/default/target1) - Test how zero the zero build is. We do not expect to see any cache misses. - $ dune build --config-file=config target1 --debug-cache=shared,workspace-local - $ cat _build/log | grep '_build/default/source\|_build/default/target' + $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \ + > 2>&1 | grep '_build/default/source\|_build/default/target' [1] Test that the cache stores all historical build results. diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t index b11563e45db2..6650d7c08e99 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t @@ -29,7 +29,16 @@ It's a duck. It quacks. (Yes, the author of this comment didn't get it.) Test that after the build, the files in the build directory have the hard link counts greater than 1, because they are shared with the corresponding cache entries. - $ dune build --config-file=config target1 --debug-cache=shared,workspace-local +We expect to see both workspace-local and shared cache misses, because we've +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 [8b39c1a0b45579f8da18f42be8e6aca0] (_build/default/source): not found in cache + Workspace-local cache miss: _build/default/target1: never seen this target before + Shared cache miss [fccfd1af13c64ce19b45e2a76fb8132c] (_build/default/target1): not found in cache + $ dune_cmd stat hardlinks _build/default/source 3 $ dune_cmd stat hardlinks _build/default/target1 @@ -39,19 +48,17 @@ counts greater than 1, because they are shared with the corresponding cache entr $ dune_cmd exists _build/default/beacon true -We expect to see both workspace-local and shared cache misses in the build log, -because we've never built [target1] before. - - $ cat _build/log | grep '_build/default/source\|_build/default/target' - # Workspace-local cache miss: _build/default/source: never seen this target before - # Shared cache miss [8b39c1a0b45579f8da18f42be8e6aca0] (_build/default/source): not found in cache - # Workspace-local cache miss: _build/default/target1: never seen this target before - # Shared cache miss [fccfd1af13c64ce19b45e2a76fb8132c] (_build/default/target1): not found in cache - Test that rebuilding works. +Now we expect to see only workspace-local cache misses, because we've cleaned +[_build/default] but not the shared cache. + $ rm -rf _build/default - $ dune build --config-file=config target1 --debug-cache=shared,workspace-local + $ 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: target missing from build dir + Workspace-local cache miss: _build/default/target1: target missing from build dir + $ dune_cmd stat hardlinks _build/default/source 3 $ dune_cmd stat hardlinks _build/default/target1 @@ -68,19 +75,10 @@ Test that rebuilding works. \_o< COIN \_o< COIN -Now we expect to see only workspace-local cache misses in the build log, because -we've cleaned [_build/default] but not the shared cache. - - $ cat _build/log | grep '_build/default/source\|_build/default/target' - # Workspace-local cache miss: _build/default/source: target missing from build dir - # (_build/default/source) - # Workspace-local cache miss: _build/default/target1: target missing from build dir - # (_build/default/target1) - Test how zero the zero build is. We do not expect to see any cache misses. - $ dune build --config-file=config target1 --debug-cache=shared,workspace-local - $ cat _build/log | grep '_build/default/source\|_build/default/target' + $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \ + > 2>&1 | grep '_build/default/source\|_build/default/target' [1] Test that the cache stores all historical build results. diff --git a/test/blackbox-tests/test-cases/watching/test-1.t/run.t b/test/blackbox-tests/test-cases/watching/test-1.t/run.t index 9cd4a93dd174..013b966a0ee9 100644 --- a/test/blackbox-tests/test-cases/watching/test-1.t/run.t +++ b/test/blackbox-tests/test-cases/watching/test-1.t/run.t @@ -110,4 +110,3 @@ waiting for inotify sync waited for inotify sync Success, waiting for filesystem changes... - From fb311f30925c2ffe433139c14e2cdc211618ce81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Wed, 3 Nov 2021 15:59:59 +0000 Subject: [PATCH 32/32] Move the sandbox configuration as a field of Action.Full.t (#5080) Signed-off-by: Jeremie Dimino --- src/dune_engine/action.ml | 16 +++- src/dune_engine/action.mli | 13 +++ src/dune_engine/build_system.ml | 82 ++++++++++++------- src/dune_engine/dep.ml | 39 +-------- src/dune_engine/dep.mli | 7 +- src/dune_engine/reflection.ml | 3 +- src/dune_engine/rule.ml | 38 +-------- src/dune_engine/rule.mli | 3 +- src/dune_rules/action_unexpanded.ml | 8 +- src/dune_rules/context.ml | 2 + src/dune_rules/coq_rules.ml | 5 +- src/dune_rules/cram_rules.ml | 19 ++--- src/dune_rules/dep_conf_eval.ml | 28 +++++-- src/dune_rules/dep_conf_eval.mli | 7 +- src/dune_rules/exe.ml | 23 +++--- src/dune_rules/exe.mli | 3 + src/dune_rules/exe_rules.ml | 6 +- src/dune_rules/foreign_rules.ml | 40 +++++---- src/dune_rules/inline_tests.ml | 5 +- src/dune_rules/lib_rules.ml | 56 +++++++------ src/dune_rules/mdx.ml | 9 +- src/dune_rules/module.ml | 2 +- src/dune_rules/module.mli | 4 +- src/dune_rules/module_compilation.ml | 25 +++--- src/dune_rules/ocamldep.ml | 25 +++--- src/dune_rules/preprocessing.ml | 21 +++-- src/dune_rules/simple_rules.ml | 21 +++-- src/dune_rules/super_context.ml | 17 ++-- src/dune_rules/super_context.mli | 3 - .../test-cases/dune-cache/mode-copy.t/run.t | 4 +- .../dune-cache/mode-hardlink.t/run.t | 4 +- .../test-cases/dune-cache/repro-check.t/run.t | 6 +- .../test-cases/dune-cache/trim.t/run.t | 6 +- 33 files changed, 274 insertions(+), 276 deletions(-) diff --git a/src/dune_engine/action.ml b/src/dune_engine/action.ml index daf8ce235722..f0d8d5c62662 100644 --- a/src/dune_engine/action.ml +++ b/src/dune_engine/action.ml @@ -283,6 +283,7 @@ module Full = struct ; env : Env.t ; locks : Path.t list ; can_go_in_shared_cache : bool + ; sandbox : Sandbox_config.t } let empty = @@ -290,14 +291,16 @@ module Full = struct ; env = Env.empty ; locks = [] ; can_go_in_shared_cache = true + ; sandbox = Sandbox_config.default } - let combine { action; env; locks; can_go_in_shared_cache } x = + let combine { action; env; locks; can_go_in_shared_cache; sandbox } x = { action = combine action x.action ; env = Env.extend_env env x.env ; locks = locks @ x.locks ; can_go_in_shared_cache = can_go_in_shared_cache && x.can_go_in_shared_cache + ; sandbox = Sandbox_config.inter sandbox x.sandbox } end @@ -305,8 +308,15 @@ module Full = struct include Monoid.Make (T) let make ?(env = Env.empty) ?(locks = []) ?(can_go_in_shared_cache = true) - action = - { action; env; locks; can_go_in_shared_cache } + ?(sandbox = Sandbox_config.default) action = + { action; env; locks; can_go_in_shared_cache; sandbox } let map t ~f = { t with action = f t.action } + + let add_locks l t = { t with locks = t.locks @ l } + + let add_can_go_in_shared_cache b t = + { t with can_go_in_shared_cache = t.can_go_in_shared_cache && b } + + let add_sandbox s t = { t with sandbox = Sandbox_config.inter t.sandbox s } end diff --git a/src/dune_engine/action.mli b/src/dune_engine/action.mli index 7b7becb2c4c8..4f8db7ae6333 100644 --- a/src/dune_engine/action.mli +++ b/src/dune_engine/action.mli @@ -127,16 +127,29 @@ module Full : sig ; env : Env.t ; locks : Path.t list ; can_go_in_shared_cache : bool + ; sandbox : Sandbox_config.t } val make : ?env:Env.t (** default [Env.empty] *) -> ?locks:Path.t list (** default [\[\]] *) -> ?can_go_in_shared_cache:bool (** default [true] *) + -> ?sandbox:Sandbox_config.t (** default [Sandbox_config.default] *) -> action -> t val map : t -> f:(action -> action) -> t + (** The various [add_xxx] functions merge the given value with existing field + of the action. Put another way, [add_xxx x t] is the same as: + + {[ combine t (make ~xxx:x (Progn [])) ]} *) + + val add_locks : Path.t list -> t -> t + + val add_sandbox : Sandbox_config.t -> t -> t + + val add_can_go_in_shared_cache : bool -> t -> t + include Monoid with type t := t end diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index e0deee357e71..19ce3472bf18 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -729,15 +729,14 @@ end = struct ; env = Env.empty ; locks = [] ; can_go_in_shared_cache = true + ; (* There's an [assert false] in [prepare_managed_paths] + that blows up if we try to sandbox this. *) + sandbox = Sandbox_config.no_sandboxing } , Dep.Map.singleton (Dep.file path) fact )) } in - Rule.make - (* There's an [assert false] in [prepare_managed_paths] that blows up if - we try to sandbox this. *) - ~sandbox:Sandbox_config.no_sandboxing ~context:None - ~info:(Source_file_copy path) + Rule.make ~context:None ~info:(Source_file_copy path) ~targets:(Targets.File.create ctx_path) build) @@ -1310,8 +1309,7 @@ end = struct dir-digest pairs [digests] *) Dep.Fact.file_selector g digests | Universe - | Env _ - | Sandbox_config _ -> + | Env _ -> (* Facts about these dependencies are constructed in [Dep.Facts.digest]. *) Memo.Build.return Dep.Fact.nothing @@ -1373,18 +1371,26 @@ 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 = 7 + let rule_digest_version = 8 let compute_rule_digest (rule : Rule.t) ~deps ~action ~sandbox_mode ~execution_parameters = - let { Action.Full.action; env; locks; can_go_in_shared_cache } = action in + let { Action.Full.action + ; env + ; locks + ; can_go_in_shared_cache + ; sandbox = _ (* already taken into account in [sandbox_mode] *) + } = + action + in let file_targets, dir_targets = Targets.partition_map rule.targets ~file:Path.Build.to_string ~dir:Path.Build.to_string in let trace = ( rule_digest_version (* Update when changing the rule digest scheme. *) - , Dep.Facts.digest deps ~sandbox_mode ~env + , 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 @@ -1462,7 +1468,12 @@ end = struct Targets.map targets ~f:(fun ~files ~dirs -> (files, not (Path.Build.Set.is_empty dirs))) in - let { Action.Full.action; env; locks; can_go_in_shared_cache = _ } = + let { Action.Full.action + ; env + ; locks + ; can_go_in_shared_cache = _ + ; sandbox = _ + } = action in pending_targets := Path.Build.Set.union file_targets !pending_targets; @@ -1639,6 +1650,22 @@ end = struct reason) ]) + let adapt_action_for_patch_back_source_tree (action : Action.Full.t) = + (* Rules that patch back the source tree cannot go in the shared cache *) + let can_go_in_shared_cache = false in + (* Rules that patch back the source tree must be sandboxed in copy mode. + + If the user specifies (sandbox none), then we get a slightly confusing + error message. We could detect this case at parsing time and produce a + better error message. It's a bit awkard to implement this check at the + moment as the sandbox config is specified in the dependencies, but we + plan to change that in the future. *) + let sandbox = + Sandbox_config.inter action.sandbox + (Sandbox_mode.Set.singleton Sandbox_mode.copy) + in + { action with can_go_in_shared_cache; sandbox } + let execute_rule_impl ~rule_kind rule = let t = t () in let { Rule.id = _; targets; dir; context; mode; action; info = _; loc } = @@ -1661,10 +1688,8 @@ end = struct here by executing it sequentially. *) let* action, deps = Action_builder.run action Eager in let action = - (* Rules that patch back the source tree cannot go in the shared cache *) - match (mode, action.can_go_in_shared_cache) with - | Patch_back_source_tree, true -> - { action with can_go_in_shared_cache = false } + match mode with + | Patch_back_source_tree -> adapt_action_for_patch_back_source_tree action | _ -> action in let wrap_fiber f = @@ -1687,8 +1712,7 @@ end = struct let sandbox_mode = match Action.is_useful_to_sandbox action.action with | Clearly_not -> - let config = Dep.Map.sandbox_config deps in - if Sandbox_config.mem config Sandbox_mode.none then + if Sandbox_config.mem action.sandbox Sandbox_mode.none then Sandbox_mode.none else User_error.raise ~loc @@ -1698,8 +1722,7 @@ end = struct require sandboxing." ] | Maybe -> - select_sandbox_mode ~loc - (Dep.Map.sandbox_config deps) + select_sandbox_mode ~loc action.sandbox ~sandboxing_preference:t.sandboxing_preference in let always_rerun = @@ -1785,9 +1808,7 @@ end = struct | (deps, old_digest) :: rest -> let deps = Action_exec.Dynamic_dep.Set.to_dep_set deps in let* deps = Memo.Build.run (build_deps deps) in - let new_digest = - Dep.Facts.digest deps ~sandbox_mode ~env:action.env - in + let new_digest = Dep.Facts.digest deps ~env:action.env in if old_digest = new_digest then loop rest else @@ -1907,9 +1928,7 @@ end = struct let dynamic_deps_stages = List.map exec_result.action_exec_result.dynamic_deps_stages ~f:(fun (deps, fact_map) -> - ( deps - , Dep.Facts.digest fact_map ~sandbox_mode ~env:action.env - )) + (deps, Dep.Facts.digest fact_map ~env:action.env)) in let targets_digest = digest_of_target_digests targets_and_digests @@ -2060,16 +2079,16 @@ end = struct let observing_facts = () in ignore observing_facts; let act = - (* Actions that patch back the source tree cannot go in the shared - cache *) - if act.patch_back_source_tree && act.action.can_go_in_shared_cache then - { act with action = { act.action with can_go_in_shared_cache = false } } + (* Actions that patch back the source tree cannot go in the shared cache + and must be sandboxed *) + if act.patch_back_source_tree then + { act with action = adapt_action_for_patch_back_source_tree act.action } else act in let digest = let { Rule.Anonymous_action.context - ; action = { action; env; locks; can_go_in_shared_cache } + ; action = { action; env; locks; can_go_in_shared_cache; sandbox } ; loc ; dir ; alias @@ -2106,7 +2125,8 @@ end = struct , alias , capture_stdout , can_go_in_shared_cache - , patch_back_source_tree ) + , patch_back_source_tree + , sandbox ) in (* It might seem superfluous to memoize the execution here, given that a given anonymous action will typically only appear once during a given diff --git a/src/dune_engine/dep.ml b/src/dune_engine/dep.ml index 4384d02c30b1..3c2565627200 100644 --- a/src/dune_engine/dep.ml +++ b/src/dune_engine/dep.ml @@ -10,7 +10,6 @@ module T = struct | Alias of Alias.t | File_selector of File_selector.t | Universe - | Sandbox_config of Sandbox_config.t module Stable_for_digest = struct type t = @@ -22,7 +21,6 @@ module T = struct } | File_selector of Dyn.t | Universe - | Sandbox_config of Sandbox_config.t end let env e = Env e @@ -35,8 +33,6 @@ module T = struct let file_selector g = File_selector g - let sandbox_config config = Sandbox_config config - let compare x y = match (x, y) with | Env x, Env y -> Env.Var.compare x y @@ -52,30 +48,15 @@ module T = struct | File_selector _, _ -> Lt | _, File_selector _ -> Gt | Universe, Universe -> Ordering.Eq - | Universe, _ -> Lt - | _, Universe -> Gt - | Sandbox_config x, Sandbox_config y -> Sandbox_config.compare x y let encode t = let open Dune_lang.Encoder in - let sandbox_config (config : Sandbox_config.t) = - list - (fun x -> x) - (List.filter_map Sandbox_mode.all ~f:(fun mode -> - if not (Sandbox_config.mem config mode) then - Some - (pair string string ("disallow", Sandbox_mode.to_string mode)) - else - None)) - in match t with | File_selector g -> pair string File_selector.encode ("glob", g) | Env e -> pair string string ("Env", e) | File f -> pair string Dpath.encode ("File", f) | Alias a -> pair string Alias.encode ("Alias", a) | Universe -> string "Universe" - | Sandbox_config config -> - pair string sandbox_config ("Sandbox_config", config) let to_dyn t = Dyn.String (Dune_lang.to_string (encode t)) end @@ -87,17 +68,6 @@ module Map = struct include O.Map include Memo.Build.Make_map_traversals (O.Map) - let sandbox_config t = - foldi t ~init:Sandbox_config.no_special_requirements ~f:(fun x _ acc -> - match x with - | File_selector _ - | Env _ - | File _ - | Alias _ - | Universe -> - acc - | Sandbox_config config -> Sandbox_config.inter acc config) - let has_universe t = mem t Universe end @@ -315,7 +285,7 @@ module Facts = struct | Alias ps -> Path.Set.union acc ps.parent_dirs) - let digest t ~sandbox_mode ~env = + let digest t ~env = let facts = let file (p, d) = (Path.to_string p, d) in Map.foldi t ~init:[] @@ -323,10 +293,6 @@ module Facts = struct match dep with | Env var -> Env (var, Env.get env var) :: acc | Universe -> acc - | Sandbox_config config -> - assert (Sandbox_config.mem config sandbox_mode); - (* recorded globally for the whole dep set, see below *) - acc | File _ | File_selector _ | Alias _ -> ( @@ -336,7 +302,7 @@ module Facts = struct | File_selector (id, ps) -> File_selector (id, ps.digest) :: acc | Alias ps -> Alias ps.digest :: acc)) in - Digest.generic (sandbox_mode, facts) + Digest.generic facts end module Set = struct @@ -432,7 +398,6 @@ module Set = struct match dep with | Env var -> Env var :: acc | Universe -> Universe :: acc - | Sandbox_config config -> Sandbox_config config :: acc | File p -> File (Path.to_string p) :: acc | File_selector fs -> File_selector (File_selector.to_dyn fs) :: acc | Alias a -> diff --git a/src/dune_engine/dep.mli b/src/dune_engine/dep.mli index 44b9a9028fff..a02283a75105 100644 --- a/src/dune_engine/dep.mli +++ b/src/dune_engine/dep.mli @@ -6,7 +6,6 @@ type t = private | Alias of Alias.t | File_selector of File_selector.t | Universe - | Sandbox_config of Sandbox_config.t val file : Path.t -> t @@ -18,8 +17,6 @@ val file_selector : File_selector.t -> t val alias : Alias.t -> t -val sandbox_config : Sandbox_config.t -> t - val compare : t -> t -> Ordering.t module Map : sig @@ -27,8 +24,6 @@ module Map : sig include Map.S with type key := t - val sandbox_config : _ t -> Sandbox_config.t - val has_universe : _ t -> bool val parallel_map : @@ -109,7 +104,7 @@ module Facts : sig (** Parent directories of all dependencies. *) val parent_dirs : t -> Path.Set.t - val digest : t -> sandbox_mode:Sandbox_mode.t -> env:Env.t -> Digest.t + val digest : t -> env:Env.t -> Digest.t val to_dyn : t -> Dyn.t end diff --git a/src/dune_engine/reflection.ml b/src/dune_engine/reflection.ml index 20944bc56f31..ca2540b731e7 100644 --- a/src/dune_engine/reflection.ml +++ b/src/dune_engine/reflection.ml @@ -51,8 +51,7 @@ end = struct | File_selector g -> Build_system.eval_pred g | Alias a -> Expand.alias a | Env _ - | Universe - | Sandbox_config _ -> + | Universe -> Memo.Build.return Path.Set.empty) >>| Path.Set.union_all end diff --git a/src/dune_engine/rule.ml b/src/dune_engine/rule.ml index 803296135f4f..2dafe9fcd3f2 100644 --- a/src/dune_engine/rule.ml +++ b/src/dune_engine/rule.ml @@ -79,41 +79,9 @@ include T module O = Comparable.Make (T) module Set = O.Set -let add_sandbox_config : - type a. - a Action_builder.eval_mode -> Sandbox_config.t -> a Dep.Map.t -> a Dep.Map.t - = - fun mode sandbox map -> - let dep = Dep.sandbox_config sandbox in - match mode with - | Lazy -> Dep.Set.add map dep - | Eager -> Dep.Map.set map dep Dep.Fact.nothing - -let make ?(sandbox = Sandbox_config.default) ?(mode = Mode.Standard) ~context - ?(info = Info.Internal) ~targets action = - let sandbox = - match mode with - | Patch_back_source_tree -> - (* If the user specifies (sandbox none), then we get a slightly confusing - error message. We could detect this case at parsing time and produce a - better error message. It's a bit awkard to implement this check at the - moment as the sandbox config is specified in the dependencies, but we - plan to change that in the future. *) - Sandbox_config.inter sandbox - (Sandbox_mode.Set.singleton Sandbox_mode.copy) - | _ -> sandbox - in - let action = - let open Memo.Build.O in - Action_builder.memoize "Rule.make" - (Action_builder.of_thunk - { f = - (fun mode -> - let+ action, deps = Action_builder.run action mode in - let deps = add_sandbox_config mode sandbox deps in - (action, deps)) - }) - in +let make ?(mode = Mode.Standard) ~context ?(info = Info.Internal) ~targets + action = + let action = Action_builder.memoize "Rule.make" action in let report_error ?(extra_pp = []) message = match info with | From_dune_file loc -> diff --git a/src/dune_engine/rule.mli b/src/dune_engine/rule.mli index 89378e352b7c..6b45c542cad2 100644 --- a/src/dune_engine/rule.mli +++ b/src/dune_engine/rule.mli @@ -93,8 +93,7 @@ val to_dyn : t -> Dyn.t (** [make] raises an error if the set of [targets] is not well-formed. See the [Targets.Validation_result] data type for the list of possible problems. *) val make : - ?sandbox:Sandbox_config.t - -> ?mode:Mode.t + ?mode:Mode.t -> context:Build_context.t option -> ?info:Info.t -> targets:Targets.t diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index add0045149ab..566d217f2fa8 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -488,7 +488,7 @@ let rec expand (t : Action_dune_lang.t) : Action.t Action_expander.t = let expand_no_targets t ~loc ~deps:deps_written_by_user ~expander ~what = let open Action_builder.O in - let deps_builder, expander = + let deps_builder, expander, sandbox = Dep_conf_eval.named ~expander deps_written_by_user in let expander = @@ -508,12 +508,12 @@ let expand_no_targets t ~loc ~deps:deps_written_by_user ~expander ~what = let+ () = deps_builder and+ action = build in let dir = Path.build (Expander.dir expander) in - Action.Full.make (Action.Chdir (dir, action)) + Action.Full.make (Action.Chdir (dir, action)) ~sandbox let expand t ~loc ~deps:deps_written_by_user ~targets_dir ~targets:targets_written_by_user ~expander = let open Action_builder.O in - let deps_builder, expander = + let deps_builder, expander, sandbox = Dep_conf_eval.named ~expander deps_written_by_user in let expander = @@ -565,7 +565,7 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir let+ () = deps_builder and+ action = build in let dir = Path.build (Expander.dir expander) in - Action.Full.make (Action.Chdir (dir, action)) + Action.Full.make (Action.Chdir (dir, action)) ~sandbox in Action_builder.with_targets ~targets build diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml index 76a9474a33d7..176c4c5193a8 100644 --- a/src/dune_rules/context.ml +++ b/src/dune_rules/context.ml @@ -904,6 +904,7 @@ let gen_configurator_rules t = ; env = Env.empty ; locks = [] ; can_go_in_shared_cache = true + ; sandbox = Sandbox_config.no_special_requirements })) in let fn = configurator_v2 t in @@ -927,6 +928,7 @@ let gen_configurator_rules t = ; env = Env.empty ; locks = [] ; can_go_in_shared_cache = true + ; sandbox = Sandbox_config.no_special_requirements })) let force_configurator_files = diff --git a/src/dune_rules/coq_rules.ml b/src/dune_rules/coq_rules.ml index 5122046a9b6b..3cc5c92acb1c 100644 --- a/src/dune_rules/coq_rules.ml +++ b/src/dune_rules/coq_rules.ml @@ -381,11 +381,10 @@ let coqc_rule (cctx : _ Context.t) ~file_flags coq_module = let open Action_builder.With_targets.O in (* The way we handle the transitive dependencies of .vo files is not safe for sandboxing *) - Action_builder.with_no_targets - (Action_builder.dep (Dep.sandbox_config Sandbox_config.no_sandboxing)) - >>> + let sandbox = Sandbox_config.no_sandboxing in let coq_flags = Context.coq_flags cctx in Context.coqc cctx (Command.Args.dyn coq_flags :: file_flags) + >>| Action.Full.add_sandbox sandbox module Module_rule = struct type t = diff --git a/src/dune_rules/cram_rules.ml b/src/dune_rules/cram_rules.ml index b5f1ee4200d5..d4360f9db16b 100644 --- a/src/dune_rules/cram_rules.ml +++ b/src/dune_rules/cram_rules.ml @@ -9,6 +9,7 @@ type effective = { loc : Loc.t ; alias : Alias.Name.Set.t ; deps : unit Action_builder.t list + ; sandbox : Sandbox_config.t ; enabled_if : Blang.t list ; locks : Path.Set.t ; packages : Package.Name.Set.t @@ -20,6 +21,7 @@ let empty_effective = ; enabled_if = [ Blang.true_ ] ; locks = Path.Set.empty ; deps = [] + ; sandbox = Sandbox_config.needs_sandboxing ; packages = Package.Name.Set.empty } @@ -84,11 +86,8 @@ let test_rule ~sctx ~expander ~dir (spec : effective) | Dir { dir; file = _ } -> let dir = Path.build (Path.Build.append_source prefix_with dir) in Action_builder.source_tree ~dir - and+ () = - Action_builder.dep - (Dep.sandbox_config Sandbox_config.needs_sandboxing) in - Action.Full.make action ~locks + Action.Full.make action ~locks ~sandbox:spec.sandbox in Memo.Build.parallel_iter aliases ~f:(fun alias -> Alias_rules.add sctx ~alias ~loc cram)) @@ -144,15 +143,15 @@ let rules ~sctx ~expander ~dir tests = | false -> acc | true -> let* acc = acc in - let* deps = + let* deps, sandbox = match spec.deps with - | None -> Memo.Build.return acc.deps + | None -> Memo.Build.return (acc.deps, acc.sandbox) | Some deps -> - let+ (deps : unit Action_builder.t) = + let+ (deps : unit Action_builder.t), _, sandbox = let+ expander = Super_context.expander sctx ~dir in - fst (Dep_conf_eval.named ~expander deps) + Dep_conf_eval.named ~expander deps in - deps :: acc.deps + (deps :: acc.deps, Sandbox_config.inter acc.sandbox sandbox) in let enabled_if = spec.enabled_if :: acc.enabled_if in let alias = @@ -174,7 +173,7 @@ let rules ~sctx ~expander ~dir tests = >>| Path.relative (Path.build dir)) >>| Path.Set.of_list >>| Path.Set.union acc.locks in - { acc with enabled_if; locks; deps; alias; packages }) + { acc with enabled_if; locks; deps; alias; packages; sandbox }) in let test_rule () = test_rule ~sctx ~expander ~dir effective test in Only_packages.get () >>= function diff --git a/src/dune_rules/dep_conf_eval.ml b/src/dune_rules/dep_conf_eval.ml index 5d332c188699..2c5fb7b1c4fa 100644 --- a/src/dune_rules/dep_conf_eval.ml +++ b/src/dune_rules/dep_conf_eval.ml @@ -169,20 +169,24 @@ let dep expander = function (let* var = Expander.expand_str expander var_sw in let+ () = Action_builder.env_var var in []) - | Sandbox_config sandbox_config -> - Other - (let+ () = Action_builder.dep (Dep.sandbox_config sandbox_config) in - []) + | Sandbox_config _ -> Other (Action_builder.return []) let prepare_expander expander = Expander.set_expanding_what expander Deps_like_field +let add_sandbox_config acc (dep : Dep_conf.t) = + match dep with + | Sandbox_config cfg -> Sandbox_config.inter acc cfg + | _ -> acc + let unnamed ~expander l = let expander = prepare_expander expander in - List.fold_left l ~init:(Action_builder.return ()) ~f:(fun acc x -> - let+ () = acc - and+ _x = to_action_builder (dep expander x) in - ()) + ( List.fold_left l ~init:(Action_builder.return ()) ~f:(fun acc x -> + let+ () = acc + and+ _x = to_action_builder (dep expander x) in + ()) + , List.fold_left l ~init:Sandbox_config.no_special_requirements + ~f:add_sandbox_config ) let named ~expander l = let builders, bindings = @@ -239,4 +243,10 @@ let named ~expander l = in let expander = Expander.add_bindings_full expander ~bindings in let builder = Action_builder.ignore builder in - (builder, expander) + ( builder + , expander + , Bindings.fold l ~init:Sandbox_config.no_special_requirements + ~f:(fun one acc -> + match one with + | Unnamed dep -> add_sandbox_config acc dep + | Named (_, l) -> List.fold_left l ~init:acc ~f:add_sandbox_config) ) diff --git a/src/dune_rules/dep_conf_eval.mli b/src/dune_rules/dep_conf_eval.mli index 40199bce1874..7cb659045eaf 100644 --- a/src/dune_rules/dep_conf_eval.mli +++ b/src/dune_rules/dep_conf_eval.mli @@ -4,7 +4,10 @@ open! Stdune open! Dune_engine (** Evaluates unnamed dependency specifications. *) -val unnamed : expander:Expander.t -> Dep_conf.t list -> unit Action_builder.t +val unnamed : + expander:Expander.t + -> Dep_conf.t list + -> unit Action_builder.t * Sandbox_config.t (** Evaluates named dependency specifications. Return the action build that register dependencies as well as an expander that can be used to expand to @@ -12,4 +15,4 @@ val unnamed : expander:Expander.t -> Dep_conf.t list -> unit Action_builder.t val named : expander:Expander.t -> Dep_conf.t Bindings.t - -> unit Action_builder.t * Expander.t + -> unit Action_builder.t * Expander.t * Sandbox_config.t diff --git a/src/dune_rules/exe.ml b/src/dune_rules/exe.ml index 9e3923094caf..eed122ebce93 100644 --- a/src/dune_rules/exe.ml +++ b/src/dune_rules/exe.ml @@ -133,7 +133,7 @@ let exe_path_from_name cctx ~name ~(linkage : Linkage.t) = let link_exe ~loc ~name ~(linkage : Linkage.t) ~cm_files ~link_time_code_gen ~promote ?(link_args = Action_builder.return Command.Args.empty) - ?(o_files = []) cctx = + ?(o_files = []) ?(sandbox = Sandbox_config.default) cctx = let sctx = CC.super_context cctx in let ctx = SC.context sctx in let dir = CC.dir cctx in @@ -198,6 +198,7 @@ let link_exe ~loc ~name ~(linkage : Linkage.t) ~cm_files ~link_time_code_gen ; fdo_linker_script_flags ; Dyn link_args ] + >>| Action.Full.add_sandbox sandbox in SC.add_rule sctx ~loc ~dir ~mode: @@ -221,8 +222,8 @@ let link_js ~name ~cm_files ~promote cctx = Jsoo_rules.build_exe cctx ~js_of_ocaml ~src ~cm:top_sorted_cms ~flags:(Command.Args.dyn flags) ~promote -let link_many ?link_args ?o_files ?(embed_in_plugin_libraries = []) ~dep_graphs - ~programs ~linkages ~promote cctx = +let link_many ?link_args ?o_files ?(embed_in_plugin_libraries = []) ?sandbox + ~dep_graphs ~programs ~linkages ~promote cctx = let dep_graphs : Dep_graph.t Ml_kind.Dict.t = dep_graphs in let open Memo.Build.O in let modules = Compilation_context.modules cctx in @@ -254,20 +255,20 @@ let link_many ?link_args ?o_files ?(embed_in_plugin_libraries = []) ~dep_graphs Link_time_code_gen.handle_special_libs cc in link_exe cctx ~loc ~name ~linkage ~cm_files ~link_time_code_gen - ~promote ?link_args ?o_files)) + ~promote ?link_args ?o_files ?sandbox)) -let build_and_link_many ?link_args ?o_files ?embed_in_plugin_libraries ~programs - ~linkages ~promote cctx = +let build_and_link_many ?link_args ?o_files ?embed_in_plugin_libraries ?sandbox + ~programs ~linkages ~promote cctx = let open Memo.Build.O in let modules = Compilation_context.modules cctx in let* dep_graphs = Dep_rules.rules cctx ~modules in let* () = Module_compilation.build_all cctx ~dep_graphs in - link_many ?link_args ?o_files ?embed_in_plugin_libraries ~dep_graphs ~programs - ~linkages ~promote cctx + link_many ?link_args ?o_files ?embed_in_plugin_libraries ?sandbox ~dep_graphs + ~programs ~linkages ~promote cctx -let build_and_link ?link_args ?o_files ?embed_in_plugin_libraries ~program - ~linkages ~promote cctx = - build_and_link_many ?link_args ?o_files ?embed_in_plugin_libraries +let build_and_link ?link_args ?o_files ?embed_in_plugin_libraries ?sandbox + ~program ~linkages ~promote cctx = + build_and_link_many ?link_args ?o_files ?embed_in_plugin_libraries ?sandbox ~programs:[ program ] ~linkages ~promote cctx let exe_path cctx ~(program : Program.t) ~linkage = diff --git a/src/dune_rules/exe.mli b/src/dune_rules/exe.mli index 20fe39563db5..ea10dd43f9f9 100644 --- a/src/dune_rules/exe.mli +++ b/src/dune_rules/exe.mli @@ -45,6 +45,7 @@ val link_many : ?link_args:Command.Args.without_targets Command.Args.t Action_builder.t -> ?o_files:Path.t list -> ?embed_in_plugin_libraries:(Loc.t * Lib_name.t) list + -> ?sandbox:Sandbox_config.t -> dep_graphs:Dep_graph.t Import.Ml_kind.Dict.t -> programs:Program.t list -> linkages:Linkage.t list @@ -56,6 +57,7 @@ val build_and_link : ?link_args:Command.Args.without_targets Command.Args.t Action_builder.t -> ?o_files:Path.t list -> ?embed_in_plugin_libraries:(Loc.t * Lib_name.t) list + -> ?sandbox:Sandbox_config.t -> program:Program.t -> linkages:Linkage.t list -> promote:Rule.Promote.t option @@ -66,6 +68,7 @@ val build_and_link_many : ?link_args:Command.Args.without_targets Command.Args.t Action_builder.t -> ?o_files:Path.t list -> ?embed_in_plugin_libraries:(Loc.t * Lib_name.t) list + -> ?sandbox:Sandbox_config.t -> programs:Program.t list -> linkages:Linkage.t list -> promote:Rule.Promote.t option diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml index fadb6aeb9e76..cb17bc95790c 100644 --- a/src/dune_rules/exe_rules.ml +++ b/src/dune_rules/exe_rules.ml @@ -173,11 +173,11 @@ let executables_rules ~sctx ~dir ~expander ~dir_contents ~scope ~compile_info let+ () = (* Building an archive for foreign stubs, we link the corresponding object files directly to improve perf. *) + let link_deps, sandbox = Dep_conf_eval.unnamed ~expander exes.link_deps in let link_args = let standard = Action_builder.return [] in let open Action_builder.O in let link_flags = - let link_deps = Dep_conf_eval.unnamed ~expander exes.link_deps in link_deps >>> Expander.expand_and_eval_set expander exes.link_flags ~standard in @@ -213,7 +213,7 @@ let executables_rules ~sctx ~dir ~expander ~dir_contents ~scope ~compile_info match buildable.Buildable.ctypes with | None -> Exe.build_and_link_many cctx ~programs ~linkages ~link_args ~o_files - ~promote:exes.promote ~embed_in_plugin_libraries + ~promote:exes.promote ~embed_in_plugin_libraries ~sandbox | Some _ctypes -> (* Ctypes stubgen builds utility .exe files that need to share modules with this compilation context. To support that, we extract the one-time @@ -230,7 +230,7 @@ let executables_rules ~sctx ~dir ~expander ~dir_contents ~scope ~compile_info in let* () = Module_compilation.build_all cctx ~dep_graphs in Exe.link_many ~programs ~dep_graphs ~linkages ~link_args ~o_files - ~promote:exes.promote ~embed_in_plugin_libraries cctx + ~promote:exes.promote ~embed_in_plugin_libraries cctx ~sandbox in ( cctx , Merlin.make ~requires:requires_compile ~stdlib_dir ~flags ~modules diff --git a/src/dune_rules/foreign_rules.ml b/src/dune_rules/foreign_rules.ml index e97226cb22d1..942bbbd21110 100644 --- a/src/dune_rules/foreign_rules.ml +++ b/src/dune_rules/foreign_rules.ml @@ -160,21 +160,21 @@ let build_c ~kind ~sctx ~dir ~expander ~include_flags (loc, src, dst) = | Other _ -> [ A "-o"; Target dst ] in let+ () = - Super_context.add_rule sctx ~loc - ~dir - (* With sandboxing we get errors like: bar.c:2:19: fatal error: foo.cxx: - No such file or directory #include "foo.cxx". (These errors happen - only when compiling c files.) *) - ~sandbox:Sandbox_config.no_sandboxing - (let src = Path.build (Foreign.Source.path src) in - (* We have to execute the rule in the library directory as the .o is - produced in the current directory *) - Command.run ~dir:(Path.build dir) c_compiler - ([ Command.Args.dyn with_user_and_std_flags - ; S [ A "-I"; Path ctx.stdlib_dir ] - ; include_flags - ] - @ output_param @ [ A "-c"; Dep src ])) + Super_context.add_rule sctx ~loc ~dir + (let open Action_builder.With_targets.O in + let src = Path.build (Foreign.Source.path src) in + (* We have to execute the rule in the library directory as the .o is + produced in the current directory *) + Command.run ~dir:(Path.build dir) c_compiler + ([ Command.Args.dyn with_user_and_std_flags + ; S [ A "-I"; Path ctx.stdlib_dir ] + ; include_flags + ] + @ output_param @ [ A "-c"; Dep src ]) + (* With sandboxing we get errors like: bar.c:2:19: fatal error: foo.cxx: + No such file or directory #include "foo.cxx". (These errors happen only + when compiling c files.) *) + >>| Action.Full.add_sandbox Sandbox_config.no_sandboxing) in dst @@ -210,10 +210,14 @@ let build_o_files ~sctx ~foreign_sources ~(dir : Path.Build.t) ~expander let dst = Path.Build.relative dir (obj ^ ctx.lib_config.ext_obj) in let stubs = src.Foreign.Source.stubs in let extra_flags = include_dir_flags ~expander ~dir src.stubs in + let extra_deps, sandbox = + Dep_conf_eval.unnamed stubs.extra_deps ~expander + in + (* We don't sandbox the C compiler, see comment in [build_file] about + this. *) + ignore sandbox; let extra_deps = - let open Action_builder.O in - let+ () = Dep_conf_eval.unnamed stubs.extra_deps ~expander in - Command.Args.empty + Action_builder.map extra_deps ~f:(fun () -> Command.Args.empty) in let include_flags = Command.Args.S [ includes; extra_flags; Dyn extra_deps ] diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index c28724b93036..9400eb887141 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -227,7 +227,8 @@ include Sub_system.Register_end_point (struct Path.build (Path.Build.relative inline_test_dir (name ^ ext)) in let open Action_builder.O in - let+ () = Dep_conf_eval.unnamed info.deps ~expander + let deps, sandbox = Dep_conf_eval.unnamed info.deps ~expander in + let+ () = deps and+ () = Action_builder.paths source_files and+ () = Action_builder.path exe and+ action = @@ -251,7 +252,7 @@ include Sub_system.Register_end_point (struct | Ok p -> Action_builder.path p >>> Action_builder.return action) in let run_tests = Action.chdir (Path.build dir) action in - Action.Full.make + Action.Full.make ~sandbox @@ Action.progn (run_tests :: List.map source_files ~f:(fun fn -> diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index b72e53325ceb..ed8dc17614c7 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -123,33 +123,35 @@ let ocamlmklib ~loc ~c_library_flags ~sctx ~dir ~expander ~o_files ~archive_name Foreign.Archive.Name.lib_file archive_name ~dir ~ext_lib in let build ~custom ~sandbox targets = - Super_context.add_rule sctx ~sandbox ~dir ~loc - (let cclibs_args = - Expander.expand_and_eval_set expander c_library_flags - ~standard:(Action_builder.return []) - in - let ctx = Super_context.context sctx in - Command.run ~dir:(Path.build ctx.build_dir) ctx.ocamlmklib - [ A "-g" - ; (if custom then - A "-custom" - else - Command.Args.empty) - ; A "-o" - ; Path (Path.build (Foreign.Archive.Name.path ~dir archive_name)) - ; Deps o_files - ; Dyn - (* The [c_library_flags] is needed only for the [dynamic_target] - case, but we pass them unconditionally for simplicity. *) - (Action_builder.map cclibs_args ~f:(fun cclibs -> - (* https://github.com/ocaml/dune/issues/119 *) - match ctx.lib_config.ccomp_type with - | Msvc -> - let cclibs = msvc_hack_cclibs cclibs in - Command.quote_args "-ldopt" cclibs - | Other _ -> As cclibs)) - ; Hidden_targets targets - ]) + Super_context.add_rule sctx ~dir ~loc + (let open Action_builder.With_targets.O in + let cclibs_args = + Expander.expand_and_eval_set expander c_library_flags + ~standard:(Action_builder.return []) + in + let ctx = Super_context.context sctx in + Command.run ~dir:(Path.build ctx.build_dir) ctx.ocamlmklib + [ A "-g" + ; (if custom then + A "-custom" + else + Command.Args.empty) + ; A "-o" + ; Path (Path.build (Foreign.Archive.Name.path ~dir archive_name)) + ; Deps o_files + ; Dyn + (* The [c_library_flags] is needed only for the [dynamic_target] + case, but we pass them unconditionally for simplicity. *) + (Action_builder.map cclibs_args ~f:(fun cclibs -> + (* https://github.com/ocaml/dune/issues/119 *) + match ctx.lib_config.ccomp_type with + | Msvc -> + let cclibs = msvc_hack_cclibs cclibs in + Command.quote_args "-ldopt" cclibs + | Other _ -> As cclibs)) + ; Hidden_targets targets + ] + >>| Action.Full.add_sandbox sandbox) in let dynamic_target = Foreign.Archive.Name.dll_file archive_name ~dir ~ext_dll diff --git a/src/dune_rules/mdx.ml b/src/dune_rules/mdx.ml index 73510d6a6499..02afa60588eb 100644 --- a/src/dune_rules/mdx.ml +++ b/src/dune_rules/mdx.ml @@ -254,13 +254,14 @@ let gen_rules_for_single_file stanza ~sctx ~dir ~expander ~mdx_prog , [ A "test" ] @ prelude_args @ [ A "-o"; Target files.corrected; Dep (Path.build files.src) ] ) in - Action_builder.( - with_no_targets - (Dep_conf_eval.unnamed ~expander - (mdx_package_deps @ mdx_generic_deps))) + let deps, sandbox = + Dep_conf_eval.unnamed ~expander (mdx_package_deps @ mdx_generic_deps) + in + Action_builder.with_no_targets deps >>> Action_builder.with_no_targets (Action_builder.dyn_deps dyn_deps) >>> Command.run ~dir:(Path.build dir) ~stdout_to:files.corrected executable command_line + >>| Action.Full.add_sandbox sandbox in Super_context.add_rule sctx ~loc ~dir mdx_action in diff --git a/src/dune_rules/module.ml b/src/dune_rules/module.ml index b147b4a08865..d7e45d717486 100644 --- a/src/dune_rules/module.ml +++ b/src/dune_rules/module.ml @@ -123,7 +123,7 @@ end type t = { source : Source.t ; obj_name : Module_name.Unique.t - ; pp : string list Action_builder.t option + ; pp : (string list Action_builder.t * Sandbox_config.t) option ; visibility : Visibility.t ; kind : Kind.t } diff --git a/src/dune_rules/module.mli b/src/dune_rules/module.mli index 36a699bb5769..0fc1b1d20f4f 100644 --- a/src/dune_rules/module.mli +++ b/src/dune_rules/module.mli @@ -56,7 +56,7 @@ val name : t -> Module_name.t val source : t -> ml_kind:Ml_kind.t -> File.t option -val pp_flags : t -> string list Action_builder.t option +val pp_flags : t -> (string list Action_builder.t * Sandbox_config.t) option val file : t -> ml_kind:Ml_kind.t -> Path.t option @@ -75,7 +75,7 @@ val add_file : t -> Ml_kind.t -> File.t -> t val map_files : t -> f:(Ml_kind.t -> File.t -> File.t) -> t (** Set preprocessing flags *) -val set_pp : t -> string list Action_builder.t option -> t +val set_pp : t -> (string list Action_builder.t * Sandbox_config.t) option -> t val wrapped_compat : t -> t diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index 5ca906edf952..4537f9f4e26f 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -147,15 +147,16 @@ let build_cm cctx ~dep_graphs ~precompiled_cmi ~cm_kind (m : Module.t) ~phase = Command.Args.empty in let dir = ctx.build_dir in - let flags = + let flags, sandbox = let flags = Ocaml_flags.get (CC.flags cctx) mode in match Module.pp_flags m with - | None -> flags - | Some pp -> - let open Action_builder.O in - let+ flags = flags - and+ pp_flags = pp in - flags @ pp_flags + | None -> (flags, sandbox) + | Some (pp, sandbox') -> + ( (let open Action_builder.O in + let+ flags = flags + and+ pp_flags = pp in + flags @ pp_flags) + , Sandbox_config.inter sandbox sandbox' ) in let output = match phase with @@ -179,7 +180,7 @@ let build_cm cctx ~dep_graphs ~precompiled_cmi ~cm_kind (m : Module.t) ~phase = |> List.concat_map ~f:(fun p -> [ Command.Args.A "-I"; Path (Path.build p) ]) in - SC.add_rule sctx ~sandbox ~dir + SC.add_rule sctx ~dir (let open Action_builder.With_targets.O in Action_builder.with_no_targets (Action_builder.paths extra_deps) >>> Action_builder.with_no_targets other_cm_files @@ -205,7 +206,8 @@ let build_cm cctx ~dep_graphs ~precompiled_cmi ~cm_kind (m : Module.t) ~phase = ; Command.Ml_kind.flag ml_kind ; Dep src ; Hidden_targets other_targets - ])) + ] + >>| Action.Full.add_sandbox sandbox)) |> Memo.Build.Option.iter ~f:Fun.id let build_module ~dep_graphs ?(precompiled_cmi = false) cctx m = @@ -267,7 +269,7 @@ let ocamlc_i ?(flags = []) ~deps cctx (m : Module.t) ~output = in let ocaml_flags = Ocaml_flags.get (CC.flags cctx) Mode.Byte in let modules = Compilation_context.modules cctx in - SC.add_rule sctx ~sandbox ~dir + SC.add_rule sctx ~dir (Action_builder.With_targets.add ~file_targets:[ output ] (let open Action_builder.With_targets.O in Action_builder.with_no_targets cm_deps @@ -283,7 +285,8 @@ let ocamlc_i ?(flags = []) ~deps cctx (m : Module.t) ~output = ; A "-i" ; Command.Ml_kind.flag Impl ; Dep src - ])) + ] + >>| Action.Full.add_sandbox sandbox)) (* The alias module is an implementation detail to support wrapping library modules under a single toplevel name. Since OCaml doesn't have proper support diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 1b401b307153..b714b7616697 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -76,17 +76,20 @@ let deps_of ~cctx ~ml_kind unit = let open Memo.Build.O in let* () = SC.add_rule sctx ~dir - (let flags = - Option.value (Module.pp_flags unit) ~default:(Action_builder.return []) - in - Command.run context.ocamldep - ~dir:(Path.build context.build_dir) - [ A "-modules" - ; Command.Args.dyn flags - ; Command.Ml_kind.flag ml_kind - ; Dep (Module.File.path source) - ] - ~stdout_to:ocamldep_output) + (let open Action_builder.With_targets.O in + let flags, sandbox = + Option.value (Module.pp_flags unit) + ~default:(Action_builder.return [], Sandbox_config.default) + in + Command.run context.ocamldep + ~dir:(Path.build context.build_dir) + [ A "-modules" + ; Command.Args.dyn flags + ; Command.Ml_kind.flag ml_kind + ; Dep (Module.File.path source) + ] + ~stdout_to:ocamldep_output + >>| Action.Full.add_sandbox sandbox) in let build_paths dependencies = let dependency_file_path m = diff --git a/src/dune_rules/preprocessing.ml b/src/dune_rules/preprocessing.ml index be25df549272..ac4e2a15b926 100644 --- a/src/dune_rules/preprocessing.ml +++ b/src/dune_rules/preprocessing.ml @@ -318,9 +318,8 @@ let build_ppx_driver sctx ~scope ~target ~pps ~pp_names = Module.file ~ml_kind:Impl module_ |> Option.value_exn |> Path.as_in_build_dir_exn in - let add_rule ~sandbox = SC.add_rule ~sandbox sctx ~dir in let* () = - add_rule ~sandbox:Sandbox_config.default + SC.add_rule sctx ~dir (Action_builder.write_file_dyn ml_source (Resolve.read (let open Resolve.O in @@ -601,9 +600,11 @@ let make sctx ~dir ~expander ~lint ~preprocess ~preprocessor_deps Preprocess.remove_future_syntax ~for_:Compiler pp (Super_context.context sctx).version) in - let preprocessor_deps = + let preprocessor_deps, sandbox = Dep_conf_eval.unnamed preprocessor_deps ~expander - |> Action_builder.memoize "preprocessor deps" + in + let preprocessor_deps = + Action_builder.memoize "preprocessor deps" preprocessor_deps in let lint_module = Staged.unstage (lint_module sctx ~dir ~expander ~lint ~lib_name ~scope) @@ -630,7 +631,9 @@ let make sctx ~dir ~expander ~lint ~preprocess ~preprocessor_deps in SC.add_rule sctx ~loc ~dir (let open Action_builder.With_targets.O in - Action_builder.with_no_targets preprocessor_deps >>> action)) + Action_builder.with_no_targets preprocessor_deps + >>> action + >>| Action.Full.add_sandbox sandbox)) >>= setup_dialect_rules sctx ~dir ~expander in let+ () = @@ -661,8 +664,7 @@ let make sctx ~dir ~expander ~lint ~preprocess ~preprocessor_deps Memo.Build.when_ lint (fun () -> lint_module ~ast ~source:m) in pped_module ast ~f:(fun ml_kind src dst -> - SC.add_rule ~sandbox:Sandbox_config.no_special_requirements sctx - ~loc ~dir + SC.add_rule sctx ~loc ~dir (promote_correction_with_target ~suffix:corrected_suffix (Path.as_in_build_dir_exn (Option.value_exn (Module.file m ~ml_kind))) @@ -681,7 +683,8 @@ let make sctx ~dir ~expander ~lint ~preprocess ~preprocessor_deps ; Command.Ml_kind.ppx_driver_flag ml_kind ; Dep (Path.build src) ; As flags - ])))) + ] + >>| Action.Full.add_sandbox sandbox)))) else let dash_ppx_flag = Action_builder.memoize "ppx command" @@ -711,7 +714,7 @@ let make sctx ~dir ~expander ~lint ~preprocess ~preprocessor_deps in [ "-ppx"; command ]) in - let pp = Some dash_ppx_flag in + let pp = Some (dash_ppx_flag, sandbox) in fun m ~lint -> let open Memo.Build.O in let* ast = setup_dialect_rules sctx ~dir ~expander m in diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index d541daa2c9a1..9768c32f2c50 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -67,13 +67,7 @@ let add_user_rule sctx ~dir ~(rule : Rule.t) ~(action : _ Action_builder.With_targets.t) ~expander = let* build = interpret_and_add_locks ~expander rule.locks action.build in let action = { action with Action_builder.With_targets.build } in - SC.add_rule_get_targets - sctx - (* user rules may have extra requirements, in which case they will be - specified as a part of rule.deps, which will be correctly taken care of - by the action builder *) - ~sandbox:Sandbox_config.no_special_requirements ~dir ~mode:rule.mode - ~loc:rule.loc action + SC.add_rule_get_targets sctx ~dir ~mode:rule.mode ~loc:rule.loc action let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = Expander.eval_blang expander rule.enabled_if >>= function @@ -107,10 +101,11 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = | None -> expander | Some bindings -> Expander.add_bindings expander ~bindings in - let* action = + let action = Action_unexpanded.expand (snd rule.action) ~loc:(fst rule.action) ~expander ~deps:rule.deps ~targets ~targets_dir:dir in + let* action = action in match rule_kind ~rule ~action with | No_alias -> let+ targets = add_user_rule sctx ~dir ~rule ~action ~expander in @@ -233,11 +228,15 @@ let alias sctx ?extra_bindings ~dir ~expander (alias_conf : Alias_conf.t) = | true -> ( match alias_conf.action with | None -> - let builder, _expander = Dep_conf_eval.named ~expander alias_conf.deps in + let builder, _expander, _sandbox = + Dep_conf_eval.named ~expander alias_conf.deps + in Rules.Produce.Alias.add_deps alias ?loc builder | Some (action_loc, action) -> let action = - let builder, expander = Dep_conf_eval.named ~expander alias_conf.deps in + let builder, expander, sandbox = + Dep_conf_eval.named ~expander alias_conf.deps + in let open Action_builder.O in let+ () = builder and+ action = @@ -249,7 +248,7 @@ let alias sctx ?extra_bindings ~dir ~expander (alias_conf : Alias_conf.t) = Action_unexpanded.expand_no_targets action ~loc:action_loc ~expander ~deps:alias_conf.deps ~what:"aliases" in - action + { action with sandbox = Sandbox_config.inter sandbox action.sandbox } in let* action = interpret_and_add_locks ~expander alias_conf.locks action in Alias_rules.add sctx ~loc action ~alias) diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index 6f3f6baaa76a..3bc040628346 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -328,24 +328,23 @@ let extend_action t ~dir build = let env = Env.extend_env env act.env in { act with env; action } -let make_rule t ?sandbox ?mode ?loc ~dir - { Action_builder.With_targets.build; targets } = +let make_rule t ?mode ?loc ~dir { Action_builder.With_targets.build; targets } = let build = extend_action t build ~dir in - Rule.make ?sandbox ?mode ~info:(Rule.Info.of_loc_opt loc) + Rule.make ?mode ~info:(Rule.Info.of_loc_opt loc) ~context:(Some (Context.build_context t.context)) ~targets build -let add_rule t ?sandbox ?mode ?loc ~dir build = - let rule = make_rule t ?sandbox ?mode ?loc ~dir build in +let add_rule t ?mode ?loc ~dir build = + let rule = make_rule t ?mode ?loc ~dir build in Rules.Produce.rule rule -let add_rule_get_targets t ?sandbox ?mode ?loc ~dir build = - let rule = make_rule t ?sandbox ?mode ?loc ~dir build in +let add_rule_get_targets t ?mode ?loc ~dir build = + let rule = make_rule t ?mode ?loc ~dir build in let+ () = Rules.Produce.rule rule in rule.targets -let add_rules t ?sandbox ~dir builds = - Memo.Build.parallel_iter builds ~f:(add_rule t ?sandbox ~dir) +let add_rules t ~dir builds = + Memo.Build.parallel_iter builds ~f:(add_rule t ~dir) let add_alias_action t alias ~dir ~loc ?(patch_back_source_tree = false) action = diff --git a/src/dune_rules/super_context.mli b/src/dune_rules/super_context.mli index 7c1beaa1fb06..0013e4ac0df3 100644 --- a/src/dune_rules/super_context.mli +++ b/src/dune_rules/super_context.mli @@ -106,7 +106,6 @@ val find_project_by_key : t -> Dune_project.File_key.t -> Dune_project.t val add_rule : t - -> ?sandbox:Sandbox_config.t -> ?mode:Rule.Mode.t -> ?loc:Loc.t -> dir:Path.Build.t @@ -115,7 +114,6 @@ val add_rule : val add_rule_get_targets : t - -> ?sandbox:Sandbox_config.t -> ?mode:Rule.Mode.t -> ?loc:Loc.t -> dir:Path.Build.t @@ -124,7 +122,6 @@ val add_rule_get_targets : val add_rules : t - -> ?sandbox:Sandbox_config.t -> dir:Path.Build.t -> Action.Full.t Action_builder.With_targets.t list -> unit Memo.Build.t diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t index 39a0ffe60cf2..9f71d6043bd4 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t/run.t @@ -36,9 +36,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 [8b39c1a0b45579f8da18f42be8e6aca0] (_build/default/source): not found in cache + Shared cache miss [63aaebd0dc5362f9939533a561b91930] (_build/default/source): not found in cache Workspace-local cache miss: _build/default/target1: never seen this target before - Shared cache miss [fccfd1af13c64ce19b45e2a76fb8132c] (_build/default/target1): not found in cache + Shared cache miss [676360ac147f34e28acf07171eacec49] (_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/run.t b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t index 6650d7c08e99..e1df241b68f4 100644 --- a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t/run.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 [8b39c1a0b45579f8da18f42be8e6aca0] (_build/default/source): not found in cache + Shared cache miss [63aaebd0dc5362f9939533a561b91930] (_build/default/source): not found in cache Workspace-local cache miss: _build/default/target1: never seen this target before - Shared cache miss [fccfd1af13c64ce19b45e2a76fb8132c] (_build/default/target1): not found in cache + Shared cache miss [676360ac147f34e28acf07171eacec49] (_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/run.t b/test/blackbox-tests/test-cases/dune-cache/repro-check.t/run.t index dbeb3d834d4d..24b1320149b8 100644 --- a/test/blackbox-tests/test-cases/dune-cache/repro-check.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/repro-check.t/run.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 [c22cd66f69ccd6561b3b4d75f66ac0a8]: ((in_cache + Warning: cache store error [a19836dda3af8f67b5a5d1d6b1174565]: ((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 [c22cd66f69ccd6561b3b4d75f66ac0a8]: ((in_cache + Warning: cache store error [a19836dda3af8f67b5a5d1d6b1174565]: ((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 [c22cd66f69ccd6561b3b4d75f66ac0a8]: ((in_cache + Warning: cache store error [a19836dda3af8f67b5a5d1d6b1174565]: ((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/run.t b/test/blackbox-tests/test-cases/dune-cache/trim.t/run.t index 1f48a9b5c8b5..89eac061f143 100644 --- a/test/blackbox-tests/test-cases/dune-cache/trim.t/run.t +++ b/test/blackbox-tests/test-cases/dune-cache/trim.t/run.t @@ -77,10 +77,10 @@ You will also need to make sure that the cache trimmer treats new and old cache entries uniformly. $ (cd "$PWD/.xdg-cache/dune/db/meta/v5"; grep -rws . -e 'metadata' | sort) - ./35/35e3c4c23bc41f4fc922c70f55c090d8:((8:metadata)(5:files(8:target_b32:8a53bfae3829b48866079fa7f2d97781))) - ./cc/cc55701449a53c9d88c1ae9c502b0668:((8:metadata)(5:files(8:target_a32:5637dd9730e430c7477f52d46de3909c))) + ./56/5630df9c779ee6388a10f41ed819194d:((8:metadata)(5:files(8:target_b32:8a53bfae3829b48866079fa7f2d97781))) + ./7d/7d27d62a60f3631a6961f7b2be16d515:((8:metadata)(5:files(8:target_a32:5637dd9730e430c7477f52d46de3909c))) - $ dune_cmd stat size "$PWD/.xdg-cache/dune/db/meta/v5/cc/cc55701449a53c9d88c1ae9c502b0668" + $ dune_cmd stat size "$PWD/.xdg-cache/dune/db/meta/v5/7d/7d27d62a60f3631a6961f7b2be16d515" 70 Trimming the cache at this point should not remove any file entries because all