From 0c4eb9d4e2207bd31623784acf3e8133cf355ff6 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 6 Apr 2021 13:31:01 +0100 Subject: [PATCH 1/2] Add an option to swallow stdout on success To reduce the noise of large builds. Signed-off-by: Jeremie Dimino --- CHANGES.md | 3 + bin/common.ml | 19 ++- bin/common.mli | 6 +- bin/import.ml | 3 +- bin/ocaml_merlin.ml | 14 ++- bin/upgrade.ml | 7 +- src/dune_config/dune_config.ml | 12 ++ src/dune_config/dune_config.mli | 1 + src/dune_engine/action_exec.ml | 9 +- src/dune_engine/action_exec.mli | 1 + src/dune_engine/build_system.ml | 9 +- src/dune_engine/dune_engine.ml | 1 + src/dune_engine/dune_project.ml | 17 +-- src/dune_engine/dune_project.mli | 5 +- src/dune_engine/execution_parameters.ml | 36 ++++-- src/dune_engine/execution_parameters.mli | 12 +- src/dune_engine/process.ml | 113 ++++++++++++------ src/dune_engine/process.mli | 4 + src/dune_engine/source_tree.ml | 45 +++---- src/dune_engine/source_tree.mli | 26 +++- src/dune_rules/dune_load.ml | 3 +- src/dune_rules/dune_load.mli | 6 +- src/dune_rules/main.ml | 4 +- src/dune_rules/main.mli | 3 +- src/dune_rules/workspace.ml | 4 + src/dune_rules/workspace.mli | 5 + .../actions/swallog-stdout-on-success.t | 98 +++++++++++++++ .../dune_config/dune_config_test.ml | 2 + 28 files changed, 354 insertions(+), 114 deletions(-) create mode 100644 test/blackbox-tests/test-cases/actions/swallog-stdout-on-success.t diff --git a/CHANGES.md b/CHANGES.md index fe28faf1118..1aa36f98a99 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -84,6 +84,9 @@ Unreleased - Fields allowed in the config file are now also allowed in the workspace file (#4426, @jeremiedimino) +- Add an option to swallow the output of actions when they succeed, to + reduce noise of large builds (#4422, @jeremiedimino) + 2.8.5 (28/03/2021) ------------------ diff --git a/bin/common.ml b/bin/common.ml index e637fe6e2d2..47da8463c7a 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -148,7 +148,7 @@ let print_entering_message c = in Console.print [ Pp.verbatim (sprintf "Entering directory '%s'" dir) ] -let set_common ?log_file c = +let set_common ?log_file ?(recognize_jbuilder_projects = false) c = if c.root.dir <> Filename.current_dir_name then Sys.chdir c.root.dir; Path.set_root (normalize_path (Path.External.cwd ())); Path.Build.set_build_dir (Path.Build.Kind.of_string c.build_dir); @@ -168,6 +168,16 @@ let set_common ?log_file c = in Dune_config.init config; Dune_util.Log.init () ?file:log_file; + Dune_engine.Source_tree.init + (let open Memo.Build.O in + let module S = Dune_engine.Source_tree.Settings in + let+ w = Dune_rules.Workspace.workspace () in + S.builtin_default + |> S.set_ancestor_vcs c.root.ancestor_vcs + |> S.set_execution_parameters + (Dune_engine.Execution_parameters.builtin_default + |> Dune_rules.Workspace.update_execution_parameters w) + |> S.set_recognize_jbuilder_projects recognize_jbuilder_projects); Clflags.debug_dep_path := c.debug_dep_path; Clflags.debug_findlib := c.debug_findlib; Clflags.debug_backtraces c.debug_backtraces; @@ -606,6 +616,12 @@ let shared_with_config_file = ~docs ~env:(Arg.env_var ~doc "DUNE_CACHE_CHECK_PROBABILITY") ~doc) + and+ swallow_stdout_on_success = + Arg.( + value & flag + & info + [ "swallow-stdout-on-success" ] + ~doc:"Swallow the output of an action when it succeeds.") in { Dune_config.Partial.display ; concurrency @@ -617,6 +633,7 @@ let shared_with_config_file = ; cache_duplication ; cache_trim_period = None ; cache_trim_size = None + ; swallow_stdout_on_success = Option.some_if swallow_stdout_on_success true } let term = diff --git a/bin/common.mli b/bin/common.mli index 2f29603af18..314bdc9fd22 100644 --- a/bin/common.mli +++ b/bin/common.mli @@ -32,7 +32,11 @@ val prefix_target : t -> string -> string Return the final configuration, which is the same as the one returned in the [config] field of [Dune_rules.Workspace.workspace ()]) *) -val set_common : ?log_file:Dune_util.Log.File.t -> t -> Dune_config.t +val set_common : + ?log_file:Dune_util.Log.File.t + -> ?recognize_jbuilder_projects:bool + -> t + -> Dune_config.t (** [examples \[("description", "dune cmd foo"); ...\]] is an [EXAMPLES] manpage section of enumerated examples illustrating how to run the documented diff --git a/bin/import.ml b/bin/import.ml index 242f0e1b791..840b9e6cf5b 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -81,8 +81,7 @@ module Main = struct let scan_workspace (common : Common.t) = let capture_outputs = Common.capture_outputs common in - let ancestor_vcs = (Common.root common).ancestor_vcs in - scan_workspace ~capture_outputs ~ancestor_vcs () + scan_workspace ~capture_outputs () let setup ?build_mutex common config = let open Fiber.O in diff --git a/bin/ocaml_merlin.ml b/bin/ocaml_merlin.ml index c2f8afa0d38..0ded2625a45 100644 --- a/bin/ocaml_merlin.ml +++ b/bin/ocaml_merlin.ml @@ -29,10 +29,11 @@ let term = ouptut.") in let common = Common.set_print_directory common false in - let config = Common.set_common common ~log_file:No_log_file in + let config = + Common.set_common common ~log_file:No_log_file + ~recognize_jbuilder_projects:true + in Scheduler.go ~common ~config (fun () -> - Dune_engine.Source_tree.init ~recognize_jbuilder_projects:true - ~ancestor_vcs:None; match dump_config with | Some s -> Dune_rules.Merlin_server.dump s | None -> Dune_rules.Merlin_server.start ()) @@ -66,10 +67,11 @@ module Dump_dot_merlin = struct "The path to the folder of which the configuration should be \ printed. Defaults to the current directory.") in - let config = Common.set_common common ~log_file:No_log_file in + let config = + Common.set_common common ~log_file:No_log_file + ~recognize_jbuilder_projects:true + in Scheduler.go ~common ~config (fun () -> - Dune_engine.Source_tree.init ~recognize_jbuilder_projects:true - ~ancestor_vcs:None; match path with | Some s -> Dune_rules.Merlin_server.dump_dot_merlin s | None -> Dune_rules.Merlin_server.dump_dot_merlin ".") diff --git a/bin/upgrade.ml b/bin/upgrade.ml index 438175d4dd6..a6f0d8d5ad9 100644 --- a/bin/upgrade.ml +++ b/bin/upgrade.ml @@ -15,10 +15,7 @@ let info = Term.info "upgrade" ~doc ~man let term = let+ common = Common.term in - let config = Common.set_common common in - Scheduler.go ~common ~config (fun () -> - Dune_engine.Source_tree.init ~recognize_jbuilder_projects:true - ~ancestor_vcs:None; - Dune_upgrader.upgrade ()) + let config = Common.set_common common ~recognize_jbuilder_projects:true in + Scheduler.go ~common ~config (fun () -> Dune_upgrader.upgrade ()) let command = (term, info) diff --git a/src/dune_config/dune_config.ml b/src/dune_config/dune_config.ml index 0458c6e0e09..a4380917827 100644 --- a/src/dune_config/dune_config.ml +++ b/src/dune_config/dune_config.ml @@ -146,6 +146,7 @@ module type S = sig ; cache_duplication : Caching.Duplication.t field ; cache_trim_period : int field ; cache_trim_size : int64 field + ; swallow_stdout_on_success : bool field } end @@ -171,6 +172,8 @@ struct ; cache_duplication = field a.cache_duplication b.cache_duplication ; cache_trim_period = field a.cache_trim_period b.cache_trim_period ; cache_trim_size = field a.cache_trim_size b.cache_trim_size + ; swallow_stdout_on_success = + field a.swallow_stdout_on_success b.swallow_stdout_on_success } end @@ -192,6 +195,7 @@ struct ; cache_duplication ; cache_trim_period ; cache_trim_size + ; swallow_stdout_on_success } = Dyn.Encoder.record [ ("display", field Scheduler.Config.Display.to_dyn display) @@ -210,6 +214,8 @@ struct cache_duplication ) ; ("cache_trim_period", field Dyn.Encoder.int cache_trim_period) ; ("cache_trim_size", field Dyn.Encoder.int64 cache_trim_size) + ; ( "swallow_stdout_on_success" + , field Dyn.Encoder.bool swallow_stdout_on_success ) ] end @@ -233,6 +239,7 @@ module Partial = struct ; cache_trim_period = None ; cache_trim_size = None ; cache_duplication = None + ; swallow_stdout_on_success = None } include @@ -288,6 +295,7 @@ let default = ; cache_trim_period = 10 * 60 ; cache_trim_size = 10_000_000_000L ; cache_duplication = None + ; swallow_stdout_on_success = false } let decode_generic ~min_dune_version = @@ -313,6 +321,9 @@ let decode_generic ~min_dune_version = field_o "cache-trim-period" (2, 0) Dune_lang.Decoder.duration and+ cache_trim_size = field_o "cache-trim-size" (2, 0) Dune_lang.Decoder.bytes_unit + and+ swallow_stdout_on_success = + field_o_b "swallow-stdout-on-success" + ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 0)) in { Partial.display ; concurrency @@ -324,6 +335,7 @@ let decode_generic ~min_dune_version = ; cache_duplication ; cache_trim_period ; cache_trim_size + ; swallow_stdout_on_success } let decode = diff --git a/src/dune_config/dune_config.mli b/src/dune_config/dune_config.mli index 74a80d09f57..26cd22fb54c 100644 --- a/src/dune_config/dune_config.mli +++ b/src/dune_config/dune_config.mli @@ -70,6 +70,7 @@ module type S = sig ; cache_duplication : Caching.Duplication.t field ; cache_trim_period : int field ; cache_trim_size : int64 field + ; swallow_stdout_on_success : bool field } end diff --git a/src/dune_engine/action_exec.ml b/src/dune_engine/action_exec.ml index c482497fd86..f25656176f7 100644 --- a/src/dune_engine/action_exec.ml +++ b/src/dune_engine/action_exec.ml @@ -516,13 +516,18 @@ let exec_until_all_deps_ready ~ectx ~eenv t = let+ () = loop ~eenv in Exec_result.{ dynamic_deps_stages = List.rev !stages } -let exec ~targets ~context ~env ~rule_loc ~build_deps t = +let exec ~targets ~context ~env ~rule_loc ~build_deps ~execution_parameters t = let purpose = Process.Build_job targets in let ectx = { targets; purpose; context; rule_loc; build_deps } and eenv = { working_dir = Path.root ; env - ; stdout_to = Process.Io.stdout + ; stdout_to = + (if Execution_parameters.swallow_stdout_on_success execution_parameters + then + Process.Io.stdout_swallow_on_success + else + Process.Io.stdout) ; stderr_to = Process.Io.stderr ; stdin_from = Process.Io.null In ; prepared_dependencies = DAP.Dependency.Set.empty diff --git a/src/dune_engine/action_exec.mli b/src/dune_engine/action_exec.mli index e4144fbf88d..c33b654b5d4 100644 --- a/src/dune_engine/action_exec.mli +++ b/src/dune_engine/action_exec.mli @@ -33,5 +33,6 @@ val exec : -> env:Env.t -> rule_loc:Loc.t -> build_deps:(Dep.Set.t -> Dep.Fact.t Dep.Map.t Fiber.t) + -> execution_parameters:Execution_parameters.t -> Action.t -> Exec_result.t Fiber.t diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index d52f66b1470..7f650c063c1 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -1421,7 +1421,7 @@ end = struct let targets = rule.action.targets in let head_target = Path.Build.Set.choose_exn targets in let* action, deps = exec_build_request rule.action.build - and* exec_params = + and* execution_parameters = Source_tree.execution_parameters_of_dir (Path.Build.drop_build_context_exn dir) in @@ -1641,7 +1641,7 @@ end = struct let deps = if Execution_parameters.should_expand_aliases_when_sandboxing - exec_params + execution_parameters then Dep.Facts.paths deps else @@ -1664,7 +1664,7 @@ end = struct in let+ exec_result = Action_exec.exec ~context ~env ~targets ~rule_loc:loc - ~build_deps action + ~build_deps ~execution_parameters action in Option.iter sandboxed ~f:copy_files_from_sandbox; exec_result) @@ -1673,7 +1673,8 @@ end = struct (* All went well, these targets are no longer pending *) pending_targets := Path.Build.Set.diff !pending_targets targets; let targets_digests = - compute_targets_digests_or_raise_error exec_params ~loc targets + compute_targets_digests_or_raise_error execution_parameters ~loc + targets in let targets_digest = digest_of_targets_digests targets_digests in let () = diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index d5dc5a02f5b..2156bc53dfe 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -56,3 +56,4 @@ module Pform = Pform module Cm_kind = Cm_kind module Mode = Mode module Fs_notify_memo = Fs_notify_memo +module Execution_parameters = Execution_parameters diff --git a/src/dune_engine/dune_project.ml b/src/dune_engine/dune_project.ml index 5f7e4da03d5..57c3f026ed9 100644 --- a/src/dune_engine/dune_project.ml +++ b/src/dune_engine/dune_project.ml @@ -135,6 +135,7 @@ type t = { name : Name.t ; root : Path.Source.t ; version : string option + ; dune_version : Dune_lang.Syntax.Version.t ; info : Package.Info.t ; packages : Package.t Package.Name.Map.t ; stanza_parser : Stanza.t list Dune_lang.Decoder.t @@ -152,7 +153,6 @@ type t = ; format_config : Format_config.t option ; strict_package_deps : bool ; cram : bool - ; execution_parameters : Execution_parameters.t } let equal = ( == ) @@ -183,14 +183,13 @@ let dialects t = t.dialects let explicit_js_mode t = t.explicit_js_mode -let execution_parameters t = t.execution_parameters - -let dune_version t = Execution_parameters.dune_version t.execution_parameters +let dune_version t = t.dune_version let to_dyn { name ; root ; version + ; dune_version ; info ; project_file ; parsing_context = _ @@ -208,13 +207,13 @@ let to_dyn ; format_config ; strict_package_deps ; cram - ; execution_parameters } = let open Dyn.Encoder in record [ ("name", Name.to_dyn name) ; ("root", Path.Source.to_dyn root) ; ("version", (option string) version) + ; ("dune_version", Dune_lang.Syntax.Version.to_dyn dune_version) ; ("info", Package.Info.to_dyn info) ; ("project_file", Path.Source.to_dyn project_file) ; ( "packages" @@ -231,7 +230,6 @@ let to_dyn ; ("format_config", option Format_config.to_dyn format_config) ; ("strict_package_deps", bool strict_package_deps) ; ("cram", bool cram) - ; ("execution_parameters", Execution_parameters.to_dyn execution_parameters) ] let find_extension_args t key = Univ_map.find t.extension_args key @@ -494,6 +492,7 @@ let infer ~dir packages = ; root ; info = Package.Info.empty ; version = None + ; dune_version = lang.version ; implicit_transitive_deps ; wrapped_executables ; executables_implicit_empty_intf @@ -513,7 +512,6 @@ let infer ~dir packages = ; format_config = None ; strict_package_deps ; cram - ; execution_parameters = Execution_parameters.make ~dune_version:lang.version } module Toggle = struct @@ -759,6 +757,7 @@ let parse ~dir ~lang ~opam_packages ~file ~dir_status = ; file_key ; root ; version + ; dune_version ; info ; packages ; stanza_parser @@ -775,7 +774,6 @@ let parse ~dir ~lang ~opam_packages ~file ~dir_status = ; format_config ; strict_package_deps ; cram - ; execution_parameters = Execution_parameters.make ~dune_version })) let load_dune_project ~dir opam_packages ~dir_status = @@ -827,3 +825,6 @@ let strict_package_deps t = t.strict_package_deps let cram t = t.cram let info t = t.info + +let update_execution_parameters t ep = + Execution_parameters.set_dune_version t.dune_version ep diff --git a/src/dune_engine/dune_project.mli b/src/dune_engine/dune_project.mli index 69d07c2d610..8ba40f70039 100644 --- a/src/dune_engine/dune_project.mli +++ b/src/dune_engine/dune_project.mli @@ -169,4 +169,7 @@ val cram : t -> bool val info : t -> Package.Info.t -val execution_parameters : t -> Execution_parameters.t +(** Update the execution parameters according to what is written in the + [dune-project] file. *) +val update_execution_parameters : + t -> Execution_parameters.t -> Execution_parameters.t diff --git a/src/dune_engine/execution_parameters.ml b/src/dune_engine/execution_parameters.ml index fdbf86bd149..28327ca1b37 100644 --- a/src/dune_engine/execution_parameters.ml +++ b/src/dune_engine/execution_parameters.ml @@ -1,20 +1,40 @@ open Stdune -type t = { dune_version : Dune_lang.Syntax.Version.t } +module T = struct + type t = + { dune_version : Dune_lang.Syntax.Version.t + ; swallow_stdout_on_success : bool + } -let make ~dune_version = { dune_version } + let equal { dune_version; swallow_stdout_on_success } t = + Dune_lang.Syntax.Version.equal dune_version t.dune_version + && Bool.equal swallow_stdout_on_success t.swallow_stdout_on_success -let equal { dune_version } t = - Dune_lang.Syntax.Version.equal dune_version t.dune_version + let hash { dune_version; swallow_stdout_on_success } = + Hashtbl.hash + (Dune_lang.Syntax.Version.hash dune_version, swallow_stdout_on_success) -let hash { dune_version } = Dune_lang.Syntax.Version.hash dune_version + let to_dyn { dune_version; swallow_stdout_on_success } = + Dyn.Record + [ ("dune_version", Dune_lang.Syntax.Version.to_dyn dune_version) + ; ("swallow_stdout_on_success", Bool swallow_stdout_on_success) + ] +end -let dune_version t = t.dune_version +include T + +let builtin_default = + { dune_version = Stanza.latest_version; swallow_stdout_on_success = false } + +let set_dune_version x t = { t with dune_version = x } -let to_dyn { dune_version } = - Dyn.Record [ ("dune_version", Dune_lang.Syntax.Version.to_dyn dune_version) ] +let set_swallow_stdout_on_success x t = { t with swallow_stdout_on_success = x } + +let dune_version t = t.dune_version let should_remove_write_permissions_on_generated_files t = t.dune_version >= (2, 4) let should_expand_aliases_when_sandboxing t = t.dune_version >= (3, 0) + +let swallow_stdout_on_success t = t.swallow_stdout_on_success diff --git a/src/dune_engine/execution_parameters.mli b/src/dune_engine/execution_parameters.mli index ef69f3c9d2f..5a461f09db2 100644 --- a/src/dune_engine/execution_parameters.mli +++ b/src/dune_engine/execution_parameters.mli @@ -23,10 +23,20 @@ val hash : t -> int val to_dyn : t -> Dyn.t -val make : dune_version:Dune_lang.Syntax.Version.t -> t +(** {1 Constructors} *) + +val builtin_default : t + +val set_dune_version : Dune_lang.Syntax.Version.t -> t -> t + +val set_swallow_stdout_on_success : bool -> t -> t + +(** {1 Accessors} *) val dune_version : t -> Dune_lang.Syntax.Version.t val should_remove_write_permissions_on_generated_files : t -> bool val should_expand_aliases_when_sandboxing : t -> bool + +val swallow_stdout_on_success : t -> bool diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index 86ced20864c..f880ed6c6ab 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -37,7 +37,12 @@ module Io = struct type kind = | File of Path.t | Null - | Terminal + | Terminal of + { swallow_on_success : bool + (* This argument makes no sense for inputs, but it seems annoying + to change, especially as this code is meant to change again in + #4435. *) + } type status = | Keep_open @@ -74,20 +79,23 @@ module Io = struct ; mutable status : status } - let terminal ch = + let terminal ch ~swallow_on_success = let fd = descr_of_channel ch in - { kind = Terminal + { kind = Terminal { swallow_on_success } ; mode = mode_of_channel ch ; fd = lazy fd ; channel = lazy ch ; status = Keep_open } - let stdout = terminal (Out_chan stdout) + let stdout_swallow_on_success = + terminal (Out_chan stdout) ~swallow_on_success:true - let stderr = terminal (Out_chan stderr) + let stdout = terminal (Out_chan stdout) ~swallow_on_success:false - let stdin = terminal (In_chan stdin) + let stderr = terminal (Out_chan stderr) ~swallow_on_success:false + + let stdin = terminal (In_chan stdin) ~swallow_on_success:false let null (type a) (mode : a mode) : a t = let fd = @@ -143,7 +151,7 @@ type purpose = let io_to_redirection_path (kind : Io.kind) = match kind with - | Terminal -> None + | Terminal _ -> None | Null -> Some (Path.to_string Config.dev_null) | File fn -> Some (Path.to_string fn) @@ -158,7 +166,7 @@ let command_line_enclosers ~dir ~(stdout_to : Io.output Io.t) let suffix = match stdin_from.kind with | Null - | Terminal -> + | Terminal _ -> suffix | File fn -> suffix ^ " < " ^ quote fn in @@ -526,22 +534,42 @@ let run_internal ?dir ?(stdout_to = Io.stdout) ?(stderr_to = Io.stderr) (args, None) in let argv = prog_str :: args in - let output_filename, stdout_to, stderr_to = + let swallow_on_success (out : Io.output Io.t) = + match out.kind with + | Terminal { swallow_on_success } -> swallow_on_success + | _ -> false + in + let swallow_stdout_on_success = swallow_on_success stdout_to in + let swallow_stderr_on_success = swallow_on_success stderr_to in + let (stdout_capture, stdout_to), (stderr_capture, stderr_to) = match (stdout_to.kind, stderr_to.kind) with - | Terminal, _ - | _, Terminal + | Terminal _, _ + | _, Terminal _ when !Clflags.capture_outputs -> - let fn = Temp.create File ~prefix:"dune" ~suffix:".output" in - let terminal = Io.file fn Io.Out in - let get (out : Io.output Io.t) = - if out.kind = Terminal then ( - Io.flush out; - terminal - ) else - out + let capture () = + let fn = Temp.create File ~prefix:"dune" ~suffix:".output" in + (`Capture fn, Io.file fn Io.Out) + in + let stdout = + match stdout_to.kind with + | Terminal _ -> + Io.flush stdout_to; + capture () + | _ -> (`No_capture, stdout_to) in - (Some fn, get stdout_to, get stderr_to) - | _ -> (None, stdout_to, stderr_to) + let stderr = + match (stdout_to.kind, stderr_to.kind) with + | ( Terminal { swallow_on_success = a } + , Terminal { swallow_on_success = b } ) + when Bool.equal a b -> + (`Merged_with_stdout, snd stdout) + | _, Terminal _ -> + Io.flush stderr_to; + capture () + | _ -> (`No_capture, stderr_to) + in + (stdout, stderr) + | _ -> ((`No_capture, stdout_to), (`No_capture, stderr_to)) in let event_common, pid = (* Output.fd might create the file with Unix.openfile. We need to make @@ -577,29 +605,46 @@ let run_internal ?dir ?(stdout_to = Io.stdout) ?(stderr_to = Io.stderr) | None, None -> () | _, _ -> assert false); Option.iter response_file ~f:Path.unlink; - let output = - match output_filename with - | None -> "" - | Some fn -> - let s = Stdune.Io.read_file fn in - Temp.destroy File fn; - s - in - Log.command ~command_line ~output ~exit_status; - let exit_status : Exit_status.t = + let exit_status' : Exit_status.t = match exit_status with | WEXITED n when ok_codes n -> Ok n | WEXITED n -> Error (Failed n) | WSIGNALED n -> Error (Signaled (Signal.name n)) | WSTOPPED _ -> assert false in - match (display, exit_status, output) with + let success = Result.is_ok exit_status' in + let read_and_destroy fn ~swallow_on_success = + let s = + if success && swallow_on_success then + "" + else + Stdune.Io.read_file fn + in + Temp.destroy File fn; + s + in + let stdout = + match stdout_capture with + | `No_capture -> "" + | `Capture fn -> + read_and_destroy fn ~swallow_on_success:swallow_stdout_on_success + in + let stderr = + match stderr_capture with + | `No_capture -> "" + | `Capture fn -> + read_and_destroy fn ~swallow_on_success:swallow_stderr_on_success + | `Merged_with_stdout -> "" + in + let output = stdout ^ stderr in + Log.command ~command_line ~output ~exit_status; + match (display, exit_status', output) with | (Quiet | Progress), Ok n, "" -> n (* Optimisation for the common case *) | Verbose, _, _ -> - Exit_status.handle_verbose exit_status ~id + Exit_status.handle_verbose exit_status' ~id ~command_line:fancy_command_line ~output | _ -> - Exit_status.handle_non_verbose exit_status ~prog:prog_str ~command_line + Exit_status.handle_non_verbose exit_status' ~prog:prog_str ~command_line ~output ~purpose ~display) let run ?dir ?stdout_to ?stderr_to ?stdin_from ?env ?(purpose = Internal_job) diff --git a/src/dune_engine/process.mli b/src/dune_engine/process.mli index 4e8f4cbed48..0b6febb9597 100644 --- a/src/dune_engine/process.mli +++ b/src/dune_engine/process.mli @@ -24,6 +24,10 @@ module Io : sig val stdout : output t + (** Same as [stdout], but drop it rather than redirect it to the terminal if + the command succeeds. *) + val stdout_swallow_on_success : output t + val stderr : output t val stdin : input t diff --git a/src/dune_engine/source_tree.ml b/src/dune_engine/source_tree.ml index d06ec8102d4..1b1bbc5f8d7 100644 --- a/src/dune_engine/source_tree.ml +++ b/src/dune_engine/source_tree.ml @@ -353,43 +353,34 @@ module Dir0 = struct Path.Source.Set.add acc (Path.Source.relative t.path s)) end -module Settings : sig +module Settings = struct type t = { ancestor_vcs : Vcs.t option ; recognize_jbuilder_projects : bool + ; execution_parameters : Execution_parameters.t } - val set : t -> unit - - val get : unit -> t Memo.Build.t -end = struct - type t = - { ancestor_vcs : Vcs.t option - ; recognize_jbuilder_projects : bool + let builtin_default = + { ancestor_vcs = None + ; recognize_jbuilder_projects = false + ; execution_parameters = Execution_parameters.builtin_default } - let equal { ancestor_vcs; recognize_jbuilder_projects } y = - Option.equal Vcs.equal ancestor_vcs y.ancestor_vcs - && Bool.equal recognize_jbuilder_projects y.recognize_jbuilder_projects + let set_ancestor_vcs x t = { t with ancestor_vcs = x } - let to_dyn { ancestor_vcs; recognize_jbuilder_projects } = - let open Dyn.Encoder in - record - [ ("ancestor_vcs", option Vcs.to_dyn ancestor_vcs) - ; ("recognize_jbuilder_projects", bool recognize_jbuilder_projects) - ] + let set_recognize_jbuilder_projects x t = + { t with recognize_jbuilder_projects = x } + + let set_execution_parameters x t = { t with execution_parameters = x } - let t = Fdecl.create to_dyn + let t : t Memo.Build.t Fdecl.t = Fdecl.create Dyn.Encoder.opaque - let set x = Fdecl.set_idempotent ~equal t x + let set x = Fdecl.set t x - let get () = - let+ (_ : Memo.Run.t) = Memo.current_run () in - Fdecl.get t + let get () = Fdecl.get t end -let init ~ancestor_vcs ~recognize_jbuilder_projects = - Settings.set { ancestor_vcs; recognize_jbuilder_projects } +let init = Settings.set module rec Memoized : sig val root : unit -> Dir0.t Memo.Build.t @@ -677,8 +668,10 @@ let nearest_dir path = let execution_parameters_of_dir = let f path = - let+ dir = nearest_dir path in - Dune_project.execution_parameters (Dir0.project dir) + let+ dir = nearest_dir path + and+ settings = Settings.get () in + settings.execution_parameters + |> Dune_project.update_execution_parameters (Dir0.project dir) in let memo = Memo.create "execution-parameters-of-dir" diff --git a/src/dune_engine/source_tree.mli b/src/dune_engine/source_tree.mli index 02845305a87..40370df8689 100644 --- a/src/dune_engine/source_tree.mli +++ b/src/dune_engine/source_tree.mli @@ -70,11 +70,27 @@ module Dir : sig val to_dyn : t -> Dyn.t end -(** [set source ~ancestor_vcs ~recognize_jbuilder_projects] set the root, the - default VCS, and if jbuilder project will be recognized. It must be called - before all other calls to the file tree. All of these settings can only be - set once per dune process *) -val init : ancestor_vcs:Vcs.t option -> recognize_jbuilder_projects:bool -> unit +module Settings : sig + (** Global source tree settings. *) + type t + + val builtin_default : t + + (** The default vcs. If there is no vcs at the root of the workspace, then + this is the vcs that will be used for the root. *) + val set_ancestor_vcs : Vcs.t option -> t -> t + + (** Whether we recognise jbuilder projects. This is only set to [true] by the + upgrader. *) + val set_recognize_jbuilder_projects : bool -> t -> t + + (** The default execution parameters. *) + val set_execution_parameters : Execution_parameters.t -> t -> t +end + +(** Set the global settings for this module. This function must be called + exactly once at the beginning of the process. *) +val init : Settings.t Memo.Build.t -> unit val root : unit -> Dir.t Memo.Build.t diff --git a/src/dune_rules/dune_load.ml b/src/dune_rules/dune_load.ml index 0076c87ea4b..a0f1ae17ca4 100644 --- a/src/dune_rules/dune_load.ml +++ b/src/dune_rules/dune_load.ml @@ -211,9 +211,8 @@ module Source_tree_map_reduce = (Memo.Build) (Vcses_projects_and_dune_files) -let load ~ancestor_vcs = +let load () = let open Fiber.O in - Source_tree.init ~ancestor_vcs ~recognize_jbuilder_projects:false; let+ vcs, projects, dune_files = Memo.Build.run (let f dir : Vcses_projects_and_dune_files.t Memo.Build.t = diff --git a/src/dune_rules/dune_load.mli b/src/dune_rules/dune_load.mli index d7528a29e17..6e14c5e004e 100644 --- a/src/dune_rules/dune_load.mli +++ b/src/dune_rules/dune_load.mli @@ -20,7 +20,5 @@ type conf = private ; vcs : Vcs.t list } -(** Initialize the file tree and load all dune files. [ancestor_vcs] is the - potential VCS repository the root is contained in. That is, not the - repository the root directly contains. *) -val load : ancestor_vcs:Vcs.t option -> conf Fiber.t +(** Initialize the file tree and load all dune files. *) +val load : unit -> conf Fiber.t diff --git a/src/dune_rules/main.ml b/src/dune_rules/main.ml index a7852e1fdbe..421ad5eab17 100644 --- a/src/dune_rules/main.ml +++ b/src/dune_rules/main.ml @@ -42,9 +42,9 @@ let setup_env ~capture_outputs = let+ () = Memo.Build.run (Memo.Run.Fdecl.set Global.env env) in env -let scan_workspace ~capture_outputs ~ancestor_vcs () = +let scan_workspace ~capture_outputs () = let* env = setup_env ~capture_outputs in - let* conf = Dune_load.load ~ancestor_vcs in + let* conf = Dune_load.load () in let+ contexts = Memo.Build.run (Context.DB.all ()) in List.iter contexts ~f:(fun (ctx : Context.t) -> let open Pp.O in diff --git a/src/dune_rules/main.mli b/src/dune_rules/main.mli index 2228409810f..507416685f3 100644 --- a/src/dune_rules/main.mli +++ b/src/dune_rules/main.mli @@ -18,8 +18,7 @@ val package_install_file : workspace -> Package.Name.t -> (Path.Source.t, unit) result (** Scan the source tree and discover the overall layout of the workspace. *) -val scan_workspace : - capture_outputs:bool -> ancestor_vcs:Vcs.t option -> unit -> workspace Fiber.t +val scan_workspace : capture_outputs:bool -> unit -> workspace Fiber.t (** Load dune files and initializes the build system *) val init_build_system : diff --git a/src/dune_rules/workspace.ml b/src/dune_rules/workspace.ml index 9f272e1aeae..f0d9a36abd3 100644 --- a/src/dune_rules/workspace.ml +++ b/src/dune_rules/workspace.ml @@ -649,3 +649,7 @@ let workspace = f in Memo.exec memo + +let update_execution_parameters t ep = + Execution_parameters.set_swallow_stdout_on_success + t.config.swallow_stdout_on_success ep diff --git a/src/dune_rules/workspace.mli b/src/dune_rules/workspace.mli index a95f7353d96..77d4f727c5d 100644 --- a/src/dune_rules/workspace.mli +++ b/src/dune_rules/workspace.mli @@ -108,3 +108,8 @@ val workspace : unit -> t Memo.Build.t (** Same as [workspace ()] except that if there are errors related to fields other than the ones of [config], they are not reported. *) val workspace_config : unit -> Dune_config.t Memo.Build.t + +(** Update the execution parameters according to what is written in the + [dune-workspace] file. *) +val update_execution_parameters : + t -> Execution_parameters.t -> Execution_parameters.t diff --git a/test/blackbox-tests/test-cases/actions/swallog-stdout-on-success.t b/test/blackbox-tests/test-cases/actions/swallog-stdout-on-success.t new file mode 100644 index 00000000000..d9158479a4c --- /dev/null +++ b/test/blackbox-tests/test-cases/actions/swallog-stdout-on-success.t @@ -0,0 +1,98 @@ +Test for --swallow-stdout-on-success +==================================== + + $ export BUILD_PATH_PREFIX_MAP="sh=$(which sh):$BUILD_PATH_PREFIX_MAP" + + $ echo '(lang dune 3.0)' > dune-project + + $ cat > dune < (rule + > (alias default) + > (action (system "echo 'Hello, world!'"))) + > EOF + +By default, stdout is always printed: + + $ dune build + sh alias default + Hello, world! + +With the option, stdout is swallowed when the action succeeds: + + $ dune clean + $ dune build --swallow-stdout-on-success + +Now with an action that fails: + + $ cat > dune < (rule + > (alias default) + > (action (system "echo 'Hello, world!'; exit 1"))) + > EOF + +It is always printed in case of error: + + $ dune build + File "dune", line 1, characters 0-73: + 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] + + $ dune clean + $ dune build --swallow-stdout-on-success + File "dune", line 1, characters 0-73: + 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] + +With compound actions +--------------------- + +At the moment, the behavior is a bit odd. We swallow the stdout of the +first command but not the second: + + + $ cat > dune < (rule + > (alias default) + > (action + > (progn + > (system "echo 1") + > (system "echo 2; exit 1")))) + > EOF + + $ dune build --swallow-stdout-on-success + File "dune", line 1, characters 0-93: + 1 | (rule + 2 | (alias default) + 3 | (action + 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] + +With builtin actions +-------------------- + +We currently never swallow the output of builtin actions such as +`echo`, which is odd: + + $ cat > dune < (rule + > (alias default) + > (action (echo "Hello, world!\n"))) + > EOF + + $ dune build --swallow-stdout-on-success + Hello, world! diff --git a/test/expect-tests/dune_config/dune_config_test.ml b/test/expect-tests/dune_config/dune_config_test.ml index 04611bf68e2..5b0ab8f4711 100644 --- a/test/expect-tests/dune_config/dune_config_test.ml +++ b/test/expect-tests/dune_config/dune_config_test.ml @@ -30,6 +30,7 @@ let%expect_test _ = ; cache_duplication = None ; cache_trim_period = 120 ; cache_trim_size = 10000000000 +; swallow_stdout_on_success = false } |}] @@ -75,6 +76,7 @@ let%expect_test _ = ; cache_duplication = None ; cache_trim_period = 600 ; cache_trim_size = 2000 +; swallow_stdout_on_success = false } |}] From ab92839d9c9d3c6db3e3bce95aca884d7c8f9743 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 6 Apr 2021 18:31:59 +0100 Subject: [PATCH 2/2] _ Signed-off-by: Jeremie Dimino --- src/dune_engine/process.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index f880ed6c6ab..cb55b3b9e97 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -562,6 +562,7 @@ let run_internal ?dir ?(stdout_to = Io.stdout) ?(stderr_to = Io.stderr) | ( Terminal { swallow_on_success = a } , Terminal { swallow_on_success = b } ) when Bool.equal a b -> + Io.flush stderr_to; (`Merged_with_stdout, snd stdout) | _, Terminal _ -> Io.flush stderr_to;