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.
This commit is contained in:
parent
06710d56a9
commit
b5ae1b1f52
38
bin/main.ml
38
bin/main.ml
|
@ -15,6 +15,7 @@ type common =
|
||||||
; debug_dep_path : bool
|
; debug_dep_path : bool
|
||||||
; debug_findlib : bool
|
; debug_findlib : bool
|
||||||
; dev_mode : bool
|
; dev_mode : bool
|
||||||
|
; verbose : bool
|
||||||
; workspace_file : string option
|
; workspace_file : string option
|
||||||
; root : string
|
; root : string
|
||||||
; target_prefix : string
|
; target_prefix : string
|
||||||
|
@ -30,7 +31,8 @@ let set_common c =
|
||||||
Clflags.debug_dep_path := c.debug_dep_path;
|
Clflags.debug_dep_path := c.debug_dep_path;
|
||||||
Clflags.debug_findlib := c.debug_findlib;
|
Clflags.debug_findlib := c.debug_findlib;
|
||||||
Clflags.dev_mode := c.dev_mode;
|
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
|
if c.root <> Filename.current_dir_name then
|
||||||
Sys.chdir c.root
|
Sys.chdir c.root
|
||||||
|
|
||||||
|
@ -114,6 +116,7 @@ let common =
|
||||||
debug_dep_path
|
debug_dep_path
|
||||||
debug_findlib
|
debug_findlib
|
||||||
dev_mode
|
dev_mode
|
||||||
|
verbose
|
||||||
workspace_file
|
workspace_file
|
||||||
root
|
root
|
||||||
=
|
=
|
||||||
|
@ -128,6 +131,7 @@ let common =
|
||||||
; debug_dep_path
|
; debug_dep_path
|
||||||
; debug_findlib
|
; debug_findlib
|
||||||
; dev_mode
|
; dev_mode
|
||||||
|
; verbose
|
||||||
; workspace_file
|
; workspace_file
|
||||||
; root
|
; root
|
||||||
; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
|
; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
|
||||||
|
@ -188,6 +192,12 @@ let common =
|
||||||
& info ["dev"] ~docs
|
& info ["dev"] ~docs
|
||||||
~doc:{|Use stricter compilation flags by default.|})
|
~doc:{|Use stricter compilation flags by default.|})
|
||||||
in
|
in
|
||||||
|
let verbose =
|
||||||
|
Arg.(value
|
||||||
|
& flag
|
||||||
|
& info ["verbose"] ~docs
|
||||||
|
~doc:"Print detailed information about commands being run")
|
||||||
|
in
|
||||||
let workspace_file =
|
let workspace_file =
|
||||||
Arg.(value
|
Arg.(value
|
||||||
& opt (some file) None
|
& opt (some file) None
|
||||||
|
@ -211,6 +221,7 @@ let common =
|
||||||
$ ddep_path
|
$ ddep_path
|
||||||
$ dfindlib
|
$ dfindlib
|
||||||
$ dev
|
$ dev
|
||||||
|
$ verbose
|
||||||
$ workspace_file
|
$ workspace_file
|
||||||
$ root
|
$ root
|
||||||
)
|
)
|
||||||
|
@ -248,7 +259,7 @@ type target =
|
||||||
| File of Path.t
|
| File of Path.t
|
||||||
| Alias of Path.t * Alias.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
|
match user_targets with
|
||||||
| [] -> []
|
| [] -> []
|
||||||
| _ ->
|
| _ ->
|
||||||
|
@ -295,13 +306,15 @@ let resolve_targets common (setup : Main.setup) user_targets =
|
||||||
| l -> l
|
| l -> l
|
||||||
)
|
)
|
||||||
in
|
in
|
||||||
Printf.printf "Actual targets:\n";
|
if !Clflags.verbose then begin
|
||||||
List.iter targets ~f:(function
|
Log.info log "Actual targets:";
|
||||||
| File path ->
|
List.iter targets ~f:(function
|
||||||
Printf.printf "- %s\n" (Path.to_string path)
|
| File path ->
|
||||||
| Alias (path, _) ->
|
Log.info log @@ "- " ^ (Path.to_string path)
|
||||||
Printf.printf "- alias %s\n" (Path.to_string path));
|
| Alias (path, _) ->
|
||||||
flush stdout;
|
Log.info log @@ "- alias " ^ (Path.to_string path));
|
||||||
|
flush stdout;
|
||||||
|
end;
|
||||||
List.map targets ~f:(function
|
List.map targets ~f:(function
|
||||||
| File path -> path
|
| File path -> path
|
||||||
| Alias (_, alias) -> Alias.file alias)
|
| Alias (_, alias) -> Alias.file alias)
|
||||||
|
@ -320,7 +333,7 @@ let build_targets =
|
||||||
let log = Log.create () in
|
let log = Log.create () in
|
||||||
Future.Scheduler.go ~log
|
Future.Scheduler.go ~log
|
||||||
(Main.setup ~log common >>= fun setup ->
|
(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
|
do_build setup targets) in
|
||||||
( Term.(const go
|
( Term.(const go
|
||||||
$ common
|
$ common
|
||||||
|
@ -377,7 +390,7 @@ let external_lib_deps =
|
||||||
Future.Scheduler.go ~log
|
Future.Scheduler.go ~log
|
||||||
(Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false
|
(Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false
|
||||||
>>= fun setup ->
|
>>= fun setup ->
|
||||||
let targets = resolve_targets common setup targets in
|
let targets = resolve_targets ~log common setup targets in
|
||||||
let failure =
|
let failure =
|
||||||
String_map.fold ~init:false
|
String_map.fold ~init:false
|
||||||
(Build_system.all_lib_deps_by_context setup.build_system targets)
|
(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 ->
|
get_prefix context ~from_command_line:prefix >>= fun prefix ->
|
||||||
Future.all_unit
|
Future.all_unit
|
||||||
(List.map install_files ~f:(fun path ->
|
(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]
|
[ sprintf "-%c" what.[0]
|
||||||
; "--prefix"
|
; "--prefix"
|
||||||
; Path.to_string prefix
|
; Path.to_string prefix
|
||||||
|
|
|
@ -231,28 +231,28 @@ module Mini_shexp = struct
|
||||||
| None -> Terminal
|
| None -> Terminal
|
||||||
| Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc }
|
| 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 stdout_to = get_std_output stdout_to in
|
||||||
let stderr_to = get_std_output stderr_to in
|
let stderr_to = get_std_output stderr_to in
|
||||||
let env = Context.extend_env ~vars:env_extra ~env 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
|
(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
|
match t with
|
||||||
| Run (prog, args) ->
|
| 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) ->
|
| 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) ->
|
| 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)
|
~env_extra:(String_map.add env_extra ~key:var ~data:value)
|
||||||
| Redirect (outputs, fn, t) ->
|
| 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) ->
|
| 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 ->
|
| 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 ->
|
| Echo str ->
|
||||||
return
|
return
|
||||||
(match stdout_to with
|
(match stdout_to with
|
||||||
|
@ -311,9 +311,9 @@ module Mini_shexp = struct
|
||||||
let path, arg =
|
let path, arg =
|
||||||
Utils.system_shell_exn ~needed_to:"interpret (system ...) actions"
|
Utils.system_shell_exn ~needed_to:"interpret (system ...) actions"
|
||||||
in
|
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 ->
|
| 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")
|
(Utils.bash_exn ~needed_to:"interpret (bash ...) actions")
|
||||||
["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
||||||
| Update_file (fn, s) ->
|
| Update_file (fn, s) ->
|
||||||
|
@ -324,7 +324,7 @@ module Mini_shexp = struct
|
||||||
write_file fn s;
|
write_file fn s;
|
||||||
return ()
|
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 fn = Path.to_string fn in
|
||||||
let oc = open_out_bin fn in
|
let oc = open_out_bin fn in
|
||||||
let out = Some (fn, oc) in
|
let out = Some (fn, oc) in
|
||||||
|
@ -334,18 +334,18 @@ module Mini_shexp = struct
|
||||||
| Stderr -> (stdout_to, out)
|
| Stderr -> (stdout_to, out)
|
||||||
| Outputs -> (out, out)
|
| Outputs -> (out, out)
|
||||||
in
|
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
|
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
|
match l with
|
||||||
| [] ->
|
| [] ->
|
||||||
Future.return ()
|
Future.return ()
|
||||||
| [t] ->
|
| [t] ->
|
||||||
exec t ~dir ~env ~env_extra ~stdout_to ~stderr_to
|
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
|
||||||
| t :: rest ->
|
| t :: rest ->
|
||||||
exec t ~dir ~env ~env_extra ~stdout_to ~stderr_to >>= fun () ->
|
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to >>= fun () ->
|
||||||
exec_list rest ~dir ~env ~env_extra ~stdout_to ~stderr_to
|
exec_list rest ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
|
||||||
end
|
end
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
|
@ -382,18 +382,20 @@ let sexp_of_t { context; dir; action } =
|
||||||
in
|
in
|
||||||
Sexp.List fields
|
Sexp.List fields
|
||||||
|
|
||||||
let exec { action; dir; context } =
|
let exec ~targets { action; dir; context } =
|
||||||
let env =
|
let env =
|
||||||
match context with
|
match context with
|
||||||
| None -> Lazy.force Context.initial_env
|
| None -> Lazy.force Context.initial_env
|
||||||
| Some c -> c.env
|
| Some c -> c.env
|
||||||
in
|
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
|
~stdout_to:None ~stderr_to:None
|
||||||
|
|
||||||
type for_hash = string option * Path.t * Mini_shexp.t
|
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),
|
(Option.map context ~f:(fun c -> c.name),
|
||||||
dir,
|
dir,
|
||||||
action)
|
action)
|
||||||
|
|
|
@ -58,7 +58,7 @@ type t =
|
||||||
|
|
||||||
val t : Context.t String_map.t -> t Sexp.Of_sexp.t
|
val t : Context.t String_map.t -> t Sexp.Of_sexp.t
|
||||||
val sexp_of_t : t Sexp.To_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
|
type for_hash
|
||||||
val for_hash : t -> for_hash
|
val for_hash : t -> for_hash
|
||||||
|
|
|
@ -168,6 +168,8 @@ let styles_of_tag = function
|
||||||
| "kwd" -> [Bold; Foreground Blue]
|
| "kwd" -> [Bold; Foreground Blue]
|
||||||
| "id" -> [Bold; Foreground Yellow]
|
| "id" -> [Bold; Foreground Yellow]
|
||||||
| "prompt" -> [Bold; Foreground Green]
|
| "prompt" -> [Bold; Foreground Green]
|
||||||
|
| "details" -> [Dim; Foreground White]
|
||||||
|
| "ok" -> [Dim; Foreground Green]
|
||||||
| "debug" -> [Underlined; Foreground Bright_cyan]
|
| "debug" -> [Underlined; Foreground Bright_cyan]
|
||||||
| _ -> []
|
| _ -> []
|
||||||
|
|
||||||
|
|
|
@ -160,7 +160,7 @@ let run ?(dir=Path.root) ?stdout_to ?context ?(extra_targets=[]) prog args =
|
||||||
let action ?(dir=Path.root) ?context ~targets action =
|
let action ?(dir=Path.root) ?context ~targets action =
|
||||||
Targets targets
|
Targets targets
|
||||||
>>^ fun () ->
|
>>^ fun () ->
|
||||||
{ Action. context; dir; action }
|
{ Action. context; dir; action }
|
||||||
|
|
||||||
let update_file fn s =
|
let update_file fn s =
|
||||||
action ~targets:[fn] (Update_file (fn, s))
|
action ~targets:[fn] (Update_file (fn, s))
|
||||||
|
|
|
@ -383,7 +383,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
|
||||||
in
|
in
|
||||||
Pset.iter targets_to_remove ~f:Path.unlink_no_err;
|
Pset.iter targets_to_remove ~f:Path.unlink_no_err;
|
||||||
pending_targets := Pset.union targets_to_remove !pending_targets;
|
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 *)
|
(* All went well, these targets are no longer pending *)
|
||||||
pending_targets := Pset.diff !pending_targets targets_to_remove;
|
pending_targets := Pset.diff !pending_targets targets_to_remove;
|
||||||
refresh_targets_timestamps_after_rule_execution t targets_as_list
|
refresh_targets_timestamps_after_rule_execution t targets_as_list
|
||||||
|
|
|
@ -3,8 +3,9 @@ let concurrency = ref 4
|
||||||
let g = ref true
|
let g = ref true
|
||||||
let debug_rules = ref false
|
let debug_rules = ref false
|
||||||
let debug_actions = ref false
|
let debug_actions = ref false
|
||||||
let debug_run = ref true
|
let verbose = ref false
|
||||||
let debug_findlib = ref false
|
let debug_findlib = ref false
|
||||||
let warnings = ref "-40"
|
let warnings = ref "-40"
|
||||||
let debug_dep_path = ref false
|
let debug_dep_path = ref false
|
||||||
let dev_mode = ref false
|
let dev_mode = ref false
|
||||||
|
let workspace_root = ref "."
|
||||||
|
|
|
@ -15,8 +15,8 @@ val debug_rules : bool ref
|
||||||
(** Print actions *)
|
(** Print actions *)
|
||||||
val debug_actions : bool ref
|
val debug_actions : bool ref
|
||||||
|
|
||||||
(** Print executed commands *)
|
(** Print executed commands verbosely *)
|
||||||
val debug_run : bool ref
|
val verbose : bool ref
|
||||||
|
|
||||||
(** Print dependency path in case of error *)
|
(** Print dependency path in case of error *)
|
||||||
val debug_dep_path : bool ref
|
val debug_dep_path : bool ref
|
||||||
|
@ -29,3 +29,6 @@ val warnings : string ref
|
||||||
|
|
||||||
(** Whether we are compiling with extra warnings *)
|
(** Whether we are compiling with extra warnings *)
|
||||||
val dev_mode : bool ref
|
val dev_mode : bool ref
|
||||||
|
|
||||||
|
(** The path to the workspace root *)
|
||||||
|
val workspace_root : string ref
|
||||||
|
|
207
src/future.ml
207
src/future.ml
|
@ -177,6 +177,11 @@ and opened_file_desc =
|
||||||
| Fd of Unix.file_descr
|
| Fd of Unix.file_descr
|
||||||
| Channel of out_channel
|
| Channel of out_channel
|
||||||
|
|
||||||
|
(** Why a Future.t was run *)
|
||||||
|
type purpose =
|
||||||
|
| Internal_job
|
||||||
|
| Build_job of Path.t list
|
||||||
|
|
||||||
type job =
|
type job =
|
||||||
{ prog : string
|
{ prog : string
|
||||||
; args : string list
|
; args : string list
|
||||||
|
@ -186,11 +191,12 @@ type job =
|
||||||
; env : string array option
|
; env : string array option
|
||||||
; ivar : int Ivar.t
|
; ivar : int Ivar.t
|
||||||
; ok_codes : accepted_codes
|
; ok_codes : accepted_codes
|
||||||
|
; purpose : purpose
|
||||||
}
|
}
|
||||||
|
|
||||||
let to_run : job Queue.t = Queue.create ()
|
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 =
|
let dir =
|
||||||
match dir with
|
match dir with
|
||||||
| Some "." -> None
|
| Some "." -> None
|
||||||
|
@ -205,10 +211,11 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env fail_mode
|
||||||
; env
|
; env
|
||||||
; ivar
|
; ivar
|
||||||
; ok_codes = accepted_codes fail_mode
|
; ok_codes = accepted_codes fail_mode
|
||||||
|
; purpose
|
||||||
} to_run)
|
} to_run)
|
||||||
|
|
||||||
let run ?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 fail_mode prog args)
|
map_result fail_mode (run_internal ?dir ?stdout_to ?stderr_to ?env ~purpose fail_mode prog args)
|
||||||
~f:ignore
|
~f:ignore
|
||||||
|
|
||||||
module Temp = struct
|
module Temp = struct
|
||||||
|
@ -230,9 +237,9 @@ module Temp = struct
|
||||||
tmp_files := String_set.remove fn !tmp_files
|
tmp_files := String_set.remove fn !tmp_files
|
||||||
end
|
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
|
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 () ->
|
~f:(fun () ->
|
||||||
let x = f fn in
|
let x = f fn in
|
||||||
Temp.destroy fn;
|
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 = run_capture_gen ~f:read_file
|
||||||
let run_capture_lines = run_capture_gen ~f:lines_of_file
|
let run_capture_lines = run_capture_gen ~f:lines_of_file
|
||||||
|
|
||||||
let run_capture_line ?dir ?env fail_mode prog args =
|
let run_capture_line ?dir ?env ?(purpose=Internal_job) fail_mode prog args =
|
||||||
run_capture_gen ?dir ?env fail_mode prog args ~f:(fun fn ->
|
run_capture_gen ?dir ?env ~purpose fail_mode prog args ~f:(fun fn ->
|
||||||
match lines_of_file fn with
|
match lines_of_file fn with
|
||||||
| [x] -> x
|
| [x] -> x
|
||||||
| l ->
|
| l ->
|
||||||
|
@ -260,10 +267,10 @@ let run_capture_line ?dir ?env fail_mode prog args =
|
||||||
cmdline (String.concat l ~sep:"\n"))
|
cmdline (String.concat l ~sep:"\n"))
|
||||||
|
|
||||||
module Scheduler = struct
|
module Scheduler = struct
|
||||||
let colorize_prog s =
|
let split_prog s =
|
||||||
let len = String.length s in
|
let len = String.length s in
|
||||||
if len = 0 then
|
if len = 0 then
|
||||||
s
|
"", "", ""
|
||||||
else begin
|
else begin
|
||||||
let rec find_prog_start i =
|
let rec find_prog_start i =
|
||||||
if i < 0 then
|
if i < 0 then
|
||||||
|
@ -286,10 +293,18 @@ module Scheduler = struct
|
||||||
in
|
in
|
||||||
let before = String.sub s ~pos:0 ~len:prog_start 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 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
|
let prog = String.sub s ~pos:prog_start ~len:(prog_end - prog_start) in
|
||||||
before ^ Ansi_color.colorize ~key key ^ after
|
before, prog, after
|
||||||
end
|
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
|
let rec colorize_args = function
|
||||||
| [] -> []
|
| [] -> []
|
||||||
| "-o" :: fn :: rest ->
|
| "-o" :: fn :: rest ->
|
||||||
|
@ -319,6 +334,75 @@ module Scheduler = struct
|
||||||
| Terminal -> s
|
| Terminal -> s
|
||||||
| File fn | Opened_file { filename = fn; _ } -> sprintf "%s 2> %s" s fn
|
| 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 " @{<details>[%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 =
|
type running_job =
|
||||||
{ id : int
|
{ id : int
|
||||||
; job : job
|
; job : job
|
||||||
|
@ -350,30 +434,53 @@ module Scheduler = struct
|
||||||
~output:output
|
~output:output
|
||||||
~exit_status:status;
|
~exit_status:status;
|
||||||
if not exiting then begin
|
if not exiting then begin
|
||||||
|
let _, progname, _ = split_prog job.job.prog in
|
||||||
match status with
|
match status with
|
||||||
| WEXITED n when code_is_ok job.job.ok_codes n ->
|
| WEXITED n when code_is_ok job.job.ok_codes n ->
|
||||||
if output <> "" then
|
if !Clflags.verbose then begin
|
||||||
Format.eprintf "@{<kwd>Output@}[@{<id>%d@}]:\n%s%!" job.id output;
|
if output <> "" then
|
||||||
if n <> 0 then
|
Format.eprintf "@{<kwd>Output@}[@{<id>%d@}]:\n%s%!" job.id output;
|
||||||
Format.eprintf
|
if n <> 0 then
|
||||||
"@{<warning>Warning@}: Command [@{<id>%d@}] exited with code %d, \
|
Format.eprintf
|
||||||
but I'm ignore it, hope that's OK.\n%!" job.id n;
|
"@{<warning>Warning@}: Command [@{<id>%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 "@{<ok>%12s@} %a@." progname pp_purpose job.job.purpose;
|
||||||
|
Format.eprintf "%s%!" output;
|
||||||
|
end;
|
||||||
Ivar.fill job.job.ivar n
|
Ivar.fill job.job.ivar n
|
||||||
| WEXITED n ->
|
| WEXITED n ->
|
||||||
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] exited with code %d:\n\
|
if !Clflags.verbose then begin
|
||||||
@{<prompt>$@} %s\n%s%!"
|
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] exited with code %d:\n\
|
||||||
job.id n
|
@{<prompt>$@} %s\n%s%!"
|
||||||
(Ansi_color.strip_colors_for_stderr job.command_line)
|
job.id n
|
||||||
(Ansi_color.strip_colors_for_stderr output);
|
(Ansi_color.strip_colors_for_stderr job.command_line)
|
||||||
|
(Ansi_color.strip_colors_for_stderr output)
|
||||||
|
end else begin
|
||||||
|
Format.eprintf "@{<error>%12s@} %a @{<error>(exit %d)@}@."
|
||||||
|
progname pp_purpose job.job.purpose n;
|
||||||
|
Format.eprintf "@{<details>%s@}@."
|
||||||
|
(Ansi_color.strip job.command_line);
|
||||||
|
Format.eprintf "%s%!" output;
|
||||||
|
end;
|
||||||
die ""
|
die ""
|
||||||
| WSIGNALED n ->
|
| WSIGNALED n ->
|
||||||
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] got signal %s:\n\
|
if !Clflags.verbose then begin
|
||||||
@{<prompt>$@} %s\n%s%!"
|
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] got signal %s:\n\
|
||||||
job.id (Utils.signal_name n)
|
@{<prompt>$@} %s\n%s%!"
|
||||||
(Ansi_color.strip_colors_for_stderr job.command_line)
|
job.id (Utils.signal_name n)
|
||||||
(Ansi_color.strip_colors_for_stderr output);
|
(Ansi_color.strip_colors_for_stderr job.command_line)
|
||||||
|
(Ansi_color.strip_colors_for_stderr output);
|
||||||
|
end else begin
|
||||||
|
Format.eprintf "@{<error>%12s@} %a @{<error>(got signal %s)@}@."
|
||||||
|
progname pp_purpose job.job.purpose (Utils.signal_name n);
|
||||||
|
Format.eprintf "@{<details>%s@}@."
|
||||||
|
(Ansi_color.strip job.command_line);
|
||||||
|
Format.eprintf "%s%!" output;
|
||||||
|
end;
|
||||||
die ""
|
die ""
|
||||||
| WSTOPPED _ -> assert false
|
| WSTOPPED _ -> assert false;
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
let gen_id =
|
let gen_id =
|
||||||
|
@ -408,17 +515,36 @@ module Scheduler = struct
|
||||||
let jobs =
|
let jobs =
|
||||||
Hashtbl.fold running ~init:[] ~f:(fun ~key:_ ~data:job acc -> job :: acc)
|
Hashtbl.fold running ~init:[] ~f:(fun ~key:_ ~data:job acc -> job :: acc)
|
||||||
in
|
in
|
||||||
match jobs with
|
let rec wait_for_jobs msg_time jobs = match jobs with
|
||||||
| [] -> ()
|
| [] -> ()
|
||||||
| first :: others ->
|
| job :: jobs when msg_time > 0. ->
|
||||||
Format.eprintf "\nWaiting for the following jobs to finish: %t@."
|
let pid, status = Unix.waitpid [WNOHANG] job.pid in
|
||||||
(fun ppf ->
|
if pid <> 0 then begin
|
||||||
Format.fprintf ppf "[@{<id>%d@}]" first.id;
|
process_done job status ~exiting:true;
|
||||||
List.iter others ~f:(fun job ->
|
wait_for_jobs msg_time jobs
|
||||||
Format.fprintf ppf ", [@{<id>%d@}]" job.id));
|
end else begin
|
||||||
List.iter jobs ~f:(fun job ->
|
let dt = 0.05 in
|
||||||
let _, status = Unix.waitpid [] job.pid in
|
let _ = Unix.select [] [] [] dt in
|
||||||
process_done job status ~exiting:true)
|
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 [@{<id>%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 () =
|
let () =
|
||||||
at_exit (fun () ->
|
at_exit (fun () ->
|
||||||
|
@ -452,7 +578,7 @@ module Scheduler = struct
|
||||||
let job = Queue.pop to_run in
|
let job = Queue.pop to_run in
|
||||||
let id = gen_id () in
|
let id = gen_id () in
|
||||||
let command_line = command_line job in
|
let command_line = command_line job in
|
||||||
if !Clflags.debug_run then
|
if !Clflags.verbose then
|
||||||
Format.eprintf "@{<kwd>Running@}[@{<id>%d@}]: %s@." id
|
Format.eprintf "@{<kwd>Running@}[@{<id>%d@}]: %s@." id
|
||||||
(Ansi_color.strip_colors_for_stderr command_line);
|
(Ansi_color.strip_colors_for_stderr command_line);
|
||||||
let argv = Array.of_list (job.prog :: job.args) in
|
let argv = Array.of_list (job.prog :: job.args) in
|
||||||
|
@ -503,6 +629,7 @@ module Scheduler = struct
|
||||||
|
|
||||||
let go ?(log=Log.no_log) t =
|
let go ?(log=Log.no_log) t =
|
||||||
Lazy.force Ansi_color.setup_env_for_opam_colors;
|
Lazy.force Ansi_color.setup_env_for_opam_colors;
|
||||||
|
Log.info log ("Workspace root: " ^ !Clflags.workspace_root);
|
||||||
let cwd = Sys.getcwd () in
|
let cwd = Sys.getcwd () in
|
||||||
go_rec cwd log t
|
go_rec cwd log t
|
||||||
end
|
end
|
||||||
|
|
|
@ -44,12 +44,18 @@ and opened_file_desc =
|
||||||
| Fd of Unix.file_descr
|
| Fd of Unix.file_descr
|
||||||
| Channel of out_channel
|
| 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 *)
|
(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *)
|
||||||
val run
|
val run
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?stdout_to:std_output_to
|
-> ?stdout_to:std_output_to
|
||||||
-> ?stderr_to:std_output_to
|
-> ?stderr_to:std_output_to
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> ?purpose:purpose
|
||||||
-> (unit, 'a) failure_mode
|
-> (unit, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
|
@ -59,6 +65,7 @@ val run
|
||||||
val run_capture
|
val run_capture
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> ?purpose:purpose
|
||||||
-> (string, 'a) failure_mode
|
-> (string, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
|
@ -66,6 +73,7 @@ val run_capture
|
||||||
val run_capture_line
|
val run_capture_line
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> ?purpose:purpose
|
||||||
-> (string, 'a) failure_mode
|
-> (string, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
|
@ -73,6 +81,7 @@ val run_capture_line
|
||||||
val run_capture_lines
|
val run_capture_lines
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> ?purpose:purpose
|
||||||
-> (string list, 'a) failure_mode
|
-> (string list, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
|
|
11
src/log.ml
11
src/log.ml
|
@ -21,10 +21,13 @@ let create () =
|
||||||
Some { oc; buf; ppf }
|
Some { oc; buf; ppf }
|
||||||
|
|
||||||
let info_internal { oc; _ } str =
|
let info_internal { oc; _ } str =
|
||||||
List.iter (String.split_lines str) ~f:(function
|
let write oc =
|
||||||
| "" -> output_string oc "#\n"
|
List.iter (String.split_lines str) ~f:(function
|
||||||
| s -> Printf.fprintf oc "# %s\n" s);
|
| "" -> output_string oc "#\n"
|
||||||
flush oc
|
| s -> Printf.fprintf oc "# %s\n" s);
|
||||||
|
flush oc in
|
||||||
|
write oc;
|
||||||
|
if !Clflags.verbose then write stderr
|
||||||
|
|
||||||
let info t str =
|
let info t str =
|
||||||
match t with
|
match t with
|
||||||
|
|
16
test/jbuild
16
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)))))
|
||||||
|
|
Loading…
Reference in New Issue