From b5ae1b1f5293c308b0a3bd044e5e34477faad4e3 Mon Sep 17 00:00:00 2001 From: Stephen Dolan Date: Thu, 30 Mar 2017 17:36:58 +0100 Subject: [PATCH] Quieter output (#40) Makes the output quieter by default and add a `--verbose` argument. Print a message when waiting for background jobs to finish only it it takes more than 0.5 seconds. --- bin/main.ml | 38 +++++--- src/action.ml | 42 ++++----- src/action.mli | 2 +- src/ansi_color.ml | 2 + src/build.ml | 2 +- src/build_system.ml | 2 +- src/clflags.ml | 3 +- src/clflags.mli | 7 +- src/future.ml | 207 +++++++++++++++++++++++++++++++++++--------- src/future.mli | 9 ++ src/log.ml | 11 ++- test/jbuild | 16 ++++ 12 files changed, 259 insertions(+), 82 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 39e3d5bf..772f44c3 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -15,6 +15,7 @@ type common = ; debug_dep_path : bool ; debug_findlib : bool ; dev_mode : bool + ; verbose : bool ; workspace_file : string option ; root : string ; target_prefix : string @@ -30,7 +31,8 @@ let set_common c = Clflags.debug_dep_path := c.debug_dep_path; Clflags.debug_findlib := c.debug_findlib; Clflags.dev_mode := c.dev_mode; - Printf.eprintf "Workspace root: %s\n" c.root; + Clflags.verbose := c.verbose; + Clflags.workspace_root := c.root; if c.root <> Filename.current_dir_name then Sys.chdir c.root @@ -114,6 +116,7 @@ let common = debug_dep_path debug_findlib dev_mode + verbose workspace_file root = @@ -128,6 +131,7 @@ let common = ; debug_dep_path ; debug_findlib ; dev_mode + ; verbose ; workspace_file ; root ; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/")) @@ -188,6 +192,12 @@ let common = & info ["dev"] ~docs ~doc:{|Use stricter compilation flags by default.|}) in + let verbose = + Arg.(value + & flag + & info ["verbose"] ~docs + ~doc:"Print detailed information about commands being run") + in let workspace_file = Arg.(value & opt (some file) None @@ -211,6 +221,7 @@ let common = $ ddep_path $ dfindlib $ dev + $ verbose $ workspace_file $ root ) @@ -248,7 +259,7 @@ type target = | File of Path.t | Alias of Path.t * Alias.t -let resolve_targets common (setup : Main.setup) user_targets = +let resolve_targets ~log common (setup : Main.setup) user_targets = match user_targets with | [] -> [] | _ -> @@ -295,13 +306,15 @@ let resolve_targets common (setup : Main.setup) user_targets = | l -> l ) in - Printf.printf "Actual targets:\n"; - List.iter targets ~f:(function - | File path -> - Printf.printf "- %s\n" (Path.to_string path) - | Alias (path, _) -> - Printf.printf "- alias %s\n" (Path.to_string path)); - flush stdout; + if !Clflags.verbose then begin + Log.info log "Actual targets:"; + List.iter targets ~f:(function + | File path -> + Log.info log @@ "- " ^ (Path.to_string path) + | Alias (path, _) -> + Log.info log @@ "- alias " ^ (Path.to_string path)); + flush stdout; + end; List.map targets ~f:(function | File path -> path | Alias (_, alias) -> Alias.file alias) @@ -320,7 +333,7 @@ let build_targets = let log = Log.create () in Future.Scheduler.go ~log (Main.setup ~log common >>= fun setup -> - let targets = resolve_targets common setup targets in + let targets = resolve_targets ~log common setup targets in do_build setup targets) in ( Term.(const go $ common @@ -377,7 +390,7 @@ let external_lib_deps = Future.Scheduler.go ~log (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false >>= fun setup -> - let targets = resolve_targets common setup targets in + let targets = resolve_targets ~log common setup targets in let failure = String_map.fold ~init:false (Build_system.all_lib_deps_by_context setup.build_system targets) @@ -497,7 +510,8 @@ let install_uninstall ~what = get_prefix context ~from_command_line:prefix >>= fun prefix -> Future.all_unit (List.map install_files ~f:(fun path -> - Future.run Strict (Path.to_string opam_installer) + let purpose = Future.Build_job install_files in + Future.run ~purpose Strict (Path.to_string opam_installer) [ sprintf "-%c" what.[0] ; "--prefix" ; Path.to_string prefix diff --git a/src/action.ml b/src/action.ml index 551958bb..611aa03a 100644 --- a/src/action.ml +++ b/src/action.ml @@ -231,28 +231,28 @@ module Mini_shexp = struct | None -> Terminal | Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc } - let run ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args = + let run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args = let stdout_to = get_std_output stdout_to in let stderr_to = get_std_output stderr_to in let env = Context.extend_env ~vars:env_extra ~env in - Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to ~stderr_to + Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to ~stderr_to ~purpose (Path.reach_for_running ~from:dir prog) args - let rec exec t ~dir ~env ~env_extra ~stdout_to ~stderr_to = + let rec exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to = match t with | Run (prog, args) -> - run ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args + run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args | Chdir (dir, t) -> - exec t ~env ~env_extra ~stdout_to ~stderr_to ~dir + exec t ~purpose ~env ~env_extra ~stdout_to ~stderr_to ~dir | Setenv (var, value, t) -> - exec t ~dir ~env ~stdout_to ~stderr_to + exec t ~purpose ~dir ~env ~stdout_to ~stderr_to ~env_extra:(String_map.add env_extra ~key:var ~data:value) | Redirect (outputs, fn, t) -> - redirect outputs fn t ~dir ~env ~env_extra ~stdout_to ~stderr_to + redirect ~purpose outputs fn t ~dir ~env ~env_extra ~stdout_to ~stderr_to | Ignore (outputs, t) -> - redirect outputs Config.dev_null t ~dir ~env ~env_extra ~stdout_to ~stderr_to + redirect ~purpose outputs Config.dev_null t ~dir ~env ~env_extra ~stdout_to ~stderr_to | Progn l -> - exec_list l ~dir ~env ~env_extra ~stdout_to ~stderr_to + exec_list l ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to | Echo str -> return (match stdout_to with @@ -311,9 +311,9 @@ module Mini_shexp = struct let path, arg = Utils.system_shell_exn ~needed_to:"interpret (system ...) actions" in - run ~dir ~env ~env_extra ~stdout_to ~stderr_to path [arg; cmd] + run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to path [arg; cmd] | Bash cmd -> - run ~dir ~env ~env_extra ~stdout_to ~stderr_to + run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to (Utils.bash_exn ~needed_to:"interpret (bash ...) actions") ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] | Update_file (fn, s) -> @@ -324,7 +324,7 @@ module Mini_shexp = struct write_file fn s; return () - and redirect outputs fn t ~dir ~env ~env_extra ~stdout_to ~stderr_to = + and redirect outputs fn t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to = let fn = Path.to_string fn in let oc = open_out_bin fn in let out = Some (fn, oc) in @@ -334,18 +334,18 @@ module Mini_shexp = struct | Stderr -> (stdout_to, out) | Outputs -> (out, out) in - exec t ~dir ~env ~env_extra ~stdout_to ~stderr_to >>| fun () -> + exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to >>| fun () -> close_out oc - and exec_list l ~dir ~env ~env_extra ~stdout_to ~stderr_to = + and exec_list l ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to = match l with | [] -> Future.return () | [t] -> - exec t ~dir ~env ~env_extra ~stdout_to ~stderr_to + exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to | t :: rest -> - exec t ~dir ~env ~env_extra ~stdout_to ~stderr_to >>= fun () -> - exec_list rest ~dir ~env ~env_extra ~stdout_to ~stderr_to + exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to >>= fun () -> + exec_list rest ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to end type t = @@ -382,18 +382,20 @@ let sexp_of_t { context; dir; action } = in Sexp.List fields -let exec { action; dir; context } = +let exec ~targets { action; dir; context } = let env = match context with | None -> Lazy.force Context.initial_env | Some c -> c.env in - Mini_shexp.exec action ~dir ~env ~env_extra:String_map.empty + let targets = Path.Set.elements targets in + let purpose = Future.Build_job targets in + Mini_shexp.exec action ~purpose ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~stderr_to:None type for_hash = string option * Path.t * Mini_shexp.t -let for_hash { context; dir; action } = +let for_hash { context; dir; action; _ } = (Option.map context ~f:(fun c -> c.name), dir, action) diff --git a/src/action.mli b/src/action.mli index 456dd900..687e75d1 100644 --- a/src/action.mli +++ b/src/action.mli @@ -58,7 +58,7 @@ type t = val t : Context.t String_map.t -> t Sexp.Of_sexp.t val sexp_of_t : t Sexp.To_sexp.t -val exec : t -> unit Future.t +val exec : targets:Path.Set.t -> t -> unit Future.t type for_hash val for_hash : t -> for_hash diff --git a/src/ansi_color.ml b/src/ansi_color.ml index 060ef9f7..9c928a0a 100644 --- a/src/ansi_color.ml +++ b/src/ansi_color.ml @@ -168,6 +168,8 @@ let styles_of_tag = function | "kwd" -> [Bold; Foreground Blue] | "id" -> [Bold; Foreground Yellow] | "prompt" -> [Bold; Foreground Green] + | "details" -> [Dim; Foreground White] + | "ok" -> [Dim; Foreground Green] | "debug" -> [Underlined; Foreground Bright_cyan] | _ -> [] diff --git a/src/build.ml b/src/build.ml index 1c91c268..38f2e281 100644 --- a/src/build.ml +++ b/src/build.ml @@ -160,7 +160,7 @@ let run ?(dir=Path.root) ?stdout_to ?context ?(extra_targets=[]) prog args = let action ?(dir=Path.root) ?context ~targets action = Targets targets >>^ fun () -> - { Action. context; dir; action } + { Action. context; dir; action } let update_file fn s = action ~targets:[fn] (Update_file (fn, s)) diff --git a/src/build_system.ml b/src/build_system.ml index 825dd4b7..24e9895a 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -383,7 +383,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = in Pset.iter targets_to_remove ~f:Path.unlink_no_err; pending_targets := Pset.union targets_to_remove !pending_targets; - Action.exec action >>| fun () -> + Action.exec ~targets action >>| fun () -> (* All went well, these targets are no longer pending *) pending_targets := Pset.diff !pending_targets targets_to_remove; refresh_targets_timestamps_after_rule_execution t targets_as_list diff --git a/src/clflags.ml b/src/clflags.ml index 03f91a9f..18b74e8a 100644 --- a/src/clflags.ml +++ b/src/clflags.ml @@ -3,8 +3,9 @@ let concurrency = ref 4 let g = ref true let debug_rules = ref false let debug_actions = ref false -let debug_run = ref true +let verbose = ref false let debug_findlib = ref false let warnings = ref "-40" let debug_dep_path = ref false let dev_mode = ref false +let workspace_root = ref "." diff --git a/src/clflags.mli b/src/clflags.mli index d7f8b698..823fd537 100644 --- a/src/clflags.mli +++ b/src/clflags.mli @@ -15,8 +15,8 @@ val debug_rules : bool ref (** Print actions *) val debug_actions : bool ref -(** Print executed commands *) -val debug_run : bool ref +(** Print executed commands verbosely *) +val verbose : bool ref (** Print dependency path in case of error *) val debug_dep_path : bool ref @@ -29,3 +29,6 @@ val warnings : string ref (** Whether we are compiling with extra warnings *) val dev_mode : bool ref + +(** The path to the workspace root *) +val workspace_root : string ref diff --git a/src/future.ml b/src/future.ml index 7e99e9da..58174ca0 100644 --- a/src/future.ml +++ b/src/future.ml @@ -177,6 +177,11 @@ and opened_file_desc = | Fd of Unix.file_descr | Channel of out_channel +(** Why a Future.t was run *) +type purpose = + | Internal_job + | Build_job of Path.t list + type job = { prog : string ; args : string list @@ -186,11 +191,12 @@ type job = ; env : string array option ; ivar : int Ivar.t ; ok_codes : accepted_codes + ; purpose : purpose } let to_run : job Queue.t = Queue.create () -let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env fail_mode prog args = +let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env ~purpose fail_mode prog args = let dir = match dir with | Some "." -> None @@ -205,10 +211,11 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env fail_mode ; env ; ivar ; ok_codes = accepted_codes fail_mode + ; purpose } to_run) -let run ?dir ?stdout_to ?stderr_to ?env fail_mode prog args = - map_result fail_mode (run_internal ?dir ?stdout_to ?stderr_to ?env fail_mode prog args) +let run ?dir ?stdout_to ?stderr_to ?env ?(purpose=Internal_job) fail_mode prog args = + map_result fail_mode (run_internal ?dir ?stdout_to ?stderr_to ?env ~purpose fail_mode prog args) ~f:ignore module Temp = struct @@ -230,9 +237,9 @@ module Temp = struct tmp_files := String_set.remove fn !tmp_files end -let run_capture_gen ?dir ?env fail_mode prog args ~f = +let run_capture_gen ?dir ?env ?(purpose=Internal_job) fail_mode prog args ~f = let fn = Temp.create "jbuild" ".output" in - map_result fail_mode (run_internal ?dir ~stdout_to:(File fn) ?env fail_mode prog args) + map_result fail_mode (run_internal ?dir ~stdout_to:(File fn) ?env ~purpose fail_mode prog args) ~f:(fun () -> let x = f fn in Temp.destroy fn; @@ -241,8 +248,8 @@ let run_capture_gen ?dir ?env fail_mode prog args ~f = let run_capture = run_capture_gen ~f:read_file let run_capture_lines = run_capture_gen ~f:lines_of_file -let run_capture_line ?dir ?env fail_mode prog args = - run_capture_gen ?dir ?env fail_mode prog args ~f:(fun fn -> +let run_capture_line ?dir ?env ?(purpose=Internal_job) fail_mode prog args = + run_capture_gen ?dir ?env ~purpose fail_mode prog args ~f:(fun fn -> match lines_of_file fn with | [x] -> x | l -> @@ -260,10 +267,10 @@ let run_capture_line ?dir ?env fail_mode prog args = cmdline (String.concat l ~sep:"\n")) module Scheduler = struct - let colorize_prog s = + let split_prog s = let len = String.length s in if len = 0 then - s + "", "", "" else begin let rec find_prog_start i = if i < 0 then @@ -286,10 +293,18 @@ module Scheduler = struct in let before = String.sub s ~pos:0 ~len:prog_start in let after = String.sub s ~pos:prog_end ~len:(len - prog_end) in - let key = String.sub s ~pos:prog_start ~len:(prog_end - prog_start) in - before ^ Ansi_color.colorize ~key key ^ after + let prog = String.sub s ~pos:prog_start ~len:(prog_end - prog_start) in + before, prog, after end + let colorize_prog s = + let len = String.length s in + if len = 0 then + s + else + let before, prog, after = split_prog s in + before ^ Ansi_color.colorize ~key:prog prog ^ after + let rec colorize_args = function | [] -> [] | "-o" :: fn :: rest -> @@ -319,6 +334,75 @@ module Scheduler = struct | Terminal -> s | File fn | Opened_file { filename = fn; _ } -> sprintf "%s 2> %s" s fn + let pp_purpose ppf = function + | Internal_job -> + Format.fprintf ppf "(internal)" + | Build_job targets -> + let rec split_paths targets_acc ctxs_acc = function + | [] -> List.rev targets_acc, String_set.(elements (of_list ctxs_acc)) + | path :: rest -> + match Path.extract_build_context path with + | None -> + split_paths (Path.to_string path :: targets_acc) ctxs_acc rest + | Some ("default", filename) -> + split_paths (Path.to_string filename :: targets_acc) ctxs_acc rest + | Some (".aliases", filename) -> + let ctxs_acc, filename = match Path.extract_build_context filename with + | None -> ctxs_acc, Path.to_string filename + | Some (ctx, fn) -> + let strip_digest fn = + let fn = Path.to_string fn in + match String.rsplit2 fn ~on:'-' with + | None -> fn + | Some (name, digest) -> + match Digest.from_hex digest with + | _ -> name + | exception (Invalid_argument _) -> fn in + let ctxs_acc = + if ctx = "default" then ctxs_acc else ctx :: ctxs_acc in + ctxs_acc, strip_digest fn in + split_paths (("alias " ^ filename) :: targets_acc) ctxs_acc rest + | Some (ctx, filename) -> + split_paths (Path.to_string filename :: targets_acc) (ctx :: ctxs_acc) rest in + let target_names, contexts = split_paths [] [] targets in + let rec group_by_ext = function + | [] -> [] + | x :: xs -> + let eq_ext a b = + let chop s = + try Filename.chop_extension s with Invalid_argument _ -> s in + chop a = chop b in + let (similar, rest) = List.partition ~f:(eq_ext x) xs in + (x :: similar) :: group_by_ext rest in + let pp_ext ppf filename = + let ext = match Filename.ext filename with + | Some s when s.[0] = '.' -> + String.sub ~pos:1 ~len:(String.length s - 1) s + | Some s -> s + | None -> "" in + Format.fprintf ppf "%s" ext in + let pp_comma ppf () = Format.fprintf ppf "," in + let pp_group ppf = function + | [] -> assert false + | [s] -> Format.fprintf ppf "%s" s + | (x :: _) as group -> + Format.fprintf ppf "%s.{%a}" + (Filename.chop_extension x) + (Format.pp_print_list ~pp_sep:pp_comma pp_ext) + group in + let pp_contexts ppf = function + | [] -> () + | ctxs -> + Format.fprintf ppf " @{
[%a]@}" + (Format.pp_print_list ~pp_sep:pp_comma + (fun ppf s -> Format.fprintf ppf "%s" s)) + ctxs in + Format.fprintf ppf "%a%a" + (Format.pp_print_list ~pp_sep:pp_comma pp_group) + (group_by_ext target_names) + pp_contexts + contexts; + type running_job = { id : int ; job : job @@ -350,30 +434,53 @@ module Scheduler = struct ~output:output ~exit_status:status; if not exiting then begin + let _, progname, _ = split_prog job.job.prog in match status with | WEXITED n when code_is_ok job.job.ok_codes n -> - if output <> "" then - Format.eprintf "@{Output@}[@{%d@}]:\n%s%!" job.id output; - if n <> 0 then - Format.eprintf - "@{Warning@}: Command [@{%d@}] exited with code %d, \ - but I'm ignore it, hope that's OK.\n%!" job.id n; + if !Clflags.verbose then begin + if output <> "" then + Format.eprintf "@{Output@}[@{%d@}]:\n%s%!" job.id output; + if n <> 0 then + Format.eprintf + "@{Warning@}: Command [@{%d@}] exited with code %d, \ + but I'm ignore it, hope that's OK.\n%!" job.id n; + end else if output <> "" || job.job.purpose <> Internal_job then begin + Format.eprintf "@{%12s@} %a@." progname pp_purpose job.job.purpose; + Format.eprintf "%s%!" output; + end; Ivar.fill job.job.ivar n | WEXITED n -> - Format.eprintf "\n@{Command@} [@{%d@}] exited with code %d:\n\ - @{$@} %s\n%s%!" - job.id n - (Ansi_color.strip_colors_for_stderr job.command_line) - (Ansi_color.strip_colors_for_stderr output); + if !Clflags.verbose then begin + Format.eprintf "\n@{Command@} [@{%d@}] exited with code %d:\n\ + @{$@} %s\n%s%!" + job.id n + (Ansi_color.strip_colors_for_stderr job.command_line) + (Ansi_color.strip_colors_for_stderr output) + end else begin + Format.eprintf "@{%12s@} %a @{(exit %d)@}@." + progname pp_purpose job.job.purpose n; + Format.eprintf "@{
%s@}@." + (Ansi_color.strip job.command_line); + Format.eprintf "%s%!" output; + end; die "" | WSIGNALED n -> - Format.eprintf "\n@{Command@} [@{%d@}] got signal %s:\n\ - @{$@} %s\n%s%!" - job.id (Utils.signal_name n) - (Ansi_color.strip_colors_for_stderr job.command_line) - (Ansi_color.strip_colors_for_stderr output); + if !Clflags.verbose then begin + Format.eprintf "\n@{Command@} [@{%d@}] got signal %s:\n\ + @{$@} %s\n%s%!" + job.id (Utils.signal_name n) + (Ansi_color.strip_colors_for_stderr job.command_line) + (Ansi_color.strip_colors_for_stderr output); + end else begin + Format.eprintf "@{%12s@} %a @{(got signal %s)@}@." + progname pp_purpose job.job.purpose (Utils.signal_name n); + Format.eprintf "@{
%s@}@." + (Ansi_color.strip job.command_line); + Format.eprintf "%s%!" output; + end; die "" - | WSTOPPED _ -> assert false + | WSTOPPED _ -> assert false; + end let gen_id = @@ -408,17 +515,36 @@ module Scheduler = struct let jobs = Hashtbl.fold running ~init:[] ~f:(fun ~key:_ ~data:job acc -> job :: acc) in - match jobs with - | [] -> () - | first :: others -> - Format.eprintf "\nWaiting for the following jobs to finish: %t@." - (fun ppf -> - Format.fprintf ppf "[@{%d@}]" first.id; - List.iter others ~f:(fun job -> - Format.fprintf ppf ", [@{%d@}]" job.id)); - List.iter jobs ~f:(fun job -> - let _, status = Unix.waitpid [] job.pid in - process_done job status ~exiting:true) + let rec wait_for_jobs msg_time jobs = match jobs with + | [] -> () + | job :: jobs when msg_time > 0. -> + let pid, status = Unix.waitpid [WNOHANG] job.pid in + if pid <> 0 then begin + process_done job status ~exiting:true; + wait_for_jobs msg_time jobs + end else begin + let dt = 0.05 in + let _ = Unix.select [] [] [] dt in + wait_for_jobs (msg_time -. dt) (job :: jobs) + end + | jobs -> + if !Clflags.verbose then begin + let pp_job ppf job = + let (_, name, _) = split_prog job.job.prog in + Format.fprintf ppf "%s [@{%d@}]" name job.id in + Format.eprintf "\nWaiting for the following jobs to finish: %a@." + (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") pp_job) + jobs; + end else begin + let n = List.length jobs in + Format.eprintf "\nWaiting for %d %s to finish.@." + n + (if n = 1 then "job" else "jobs") + end; + List.iter jobs ~f:(fun job -> + let _, status = Unix.waitpid [] job.pid in + process_done job status ~exiting:true) in + wait_for_jobs 0.5 jobs let () = at_exit (fun () -> @@ -452,7 +578,7 @@ module Scheduler = struct let job = Queue.pop to_run in let id = gen_id () in let command_line = command_line job in - if !Clflags.debug_run then + if !Clflags.verbose then Format.eprintf "@{Running@}[@{%d@}]: %s@." id (Ansi_color.strip_colors_for_stderr command_line); let argv = Array.of_list (job.prog :: job.args) in @@ -503,6 +629,7 @@ module Scheduler = struct let go ?(log=Log.no_log) t = Lazy.force Ansi_color.setup_env_for_opam_colors; + Log.info log ("Workspace root: " ^ !Clflags.workspace_root); let cwd = Sys.getcwd () in go_rec cwd log t end diff --git a/src/future.mli b/src/future.mli index 5c7ea21f..1376fac2 100644 --- a/src/future.mli +++ b/src/future.mli @@ -44,12 +44,18 @@ and opened_file_desc = | Fd of Unix.file_descr | Channel of out_channel +(** Why a Future.t was run *) +type purpose = + | Internal_job + | Build_job of Path.t list + (** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *) val run : ?dir:string -> ?stdout_to:std_output_to -> ?stderr_to:std_output_to -> ?env:string array + -> ?purpose:purpose -> (unit, 'a) failure_mode -> string -> string list @@ -59,6 +65,7 @@ val run val run_capture : ?dir:string -> ?env:string array + -> ?purpose:purpose -> (string, 'a) failure_mode -> string -> string list @@ -66,6 +73,7 @@ val run_capture val run_capture_line : ?dir:string -> ?env:string array + -> ?purpose:purpose -> (string, 'a) failure_mode -> string -> string list @@ -73,6 +81,7 @@ val run_capture_line val run_capture_lines : ?dir:string -> ?env:string array + -> ?purpose:purpose -> (string list, 'a) failure_mode -> string -> string list diff --git a/src/log.ml b/src/log.ml index 4e674be4..513553c7 100644 --- a/src/log.ml +++ b/src/log.ml @@ -21,10 +21,13 @@ let create () = Some { oc; buf; ppf } let info_internal { oc; _ } str = - List.iter (String.split_lines str) ~f:(function - | "" -> output_string oc "#\n" - | s -> Printf.fprintf oc "# %s\n" s); - flush oc + let write oc = + List.iter (String.split_lines str) ~f:(function + | "" -> output_string oc "#\n" + | s -> Printf.fprintf oc "# %s\n" s); + flush oc in + write oc; + if !Clflags.verbose then write stderr let info t str = match t with diff --git a/test/jbuild b/test/jbuild index 46c7f1f7..63a86135 100644 --- a/test/jbuild +++ b/test/jbuild @@ -47,3 +47,19 @@ ))))))) +;; execute this to check the behavior when background jobs take time to finish: +;; +;; $ ./_build/default/bin/main.exe build @test/fail-with-background-jobs-running +;; +(alias + ((name sleep5) + (action (system "sleep 5")))) + +(alias + ((name sleep1-and-fail) + (action (system "sleep 1; exit 1")))) + +(alias + ((name fail-with-background-jobs-running) + (deps ((alias sleep5) + (alias sleep1-and-fail)))))