diff --git a/bin/main.ml b/bin/main.ml index cf4171b7..7028bdbf 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -37,8 +37,9 @@ let set_common c = module Main = struct include Jbuilder.Main - let setup ?filter_out_optional_stanzas_with_missing_deps common = + let setup ~log ?filter_out_optional_stanzas_with_missing_deps common = setup + ~log ?workspace_file:common.workspace_file ?only_packages:common.only_packages ?filter_out_optional_stanzas_with_missing_deps () @@ -47,8 +48,6 @@ end let do_build (setup : Main.setup) targets = Build_system.do_build_exn setup.build_system targets -let create_log = Main.create_log - type ('a, 'b) walk_result = | Cont of 'a | Stop of 'b @@ -220,7 +219,7 @@ let installed_libraries = let doc = "Print out libraries installed on the system." in let go common = set_common common; - Future.Scheduler.go ~log:(create_log ()) + Future.Scheduler.go ~log:(Log.create ()) (Context.default () >>= fun ctx -> let findlib = ctx.findlib in let pkgs = Findlib.all_packages findlib in @@ -318,8 +317,9 @@ let build_targets = let name_ = Arg.info [] ~docv:"TARGET" in let go common targets = set_common common; - Future.Scheduler.go ~log:(create_log ()) - (Main.setup common >>= fun setup -> + let log = Log.create () in + Future.Scheduler.go ~log + (Main.setup ~log common >>= fun setup -> let targets = resolve_targets common setup targets in do_build setup targets) in ( Term.(const go @@ -339,8 +339,9 @@ let runtest = let name_ = Arg.info [] ~docv:"DIR" in let go common dirs = set_common common; - Future.Scheduler.go ~log:(create_log ()) - (Main.setup common >>= fun setup -> + let log = Log.create () in + Future.Scheduler.go ~log + (Main.setup ~log common >>= fun setup -> let targets = List.map dirs ~f:(fun dir -> let dir = Path.(relative root) (prefix_target common dir) in @@ -364,8 +365,9 @@ let external_lib_deps = in let go common only_missing targets = set_common common; - Future.Scheduler.go ~log:(create_log ()) - (Main.setup common ~filter_out_optional_stanzas_with_missing_deps:false + let log = Log.create () in + 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 failure = @@ -456,8 +458,9 @@ let install_uninstall ~what = let go common prefix pkgs = set_common common; let opam_installer = opam_installer () in - Future.Scheduler.go ~log:(create_log ()) - (Main.setup common >>= fun setup -> + let log = Log.create () in + Future.Scheduler.go ~log + (Main.setup ~log common >>= fun setup -> let pkgs = match pkgs with | [] -> String_map.keys setup.packages @@ -526,8 +529,9 @@ let exec = in let go common context prog args = set_common common; - Future.Scheduler.go ~log:(create_log ()) - (Main.setup common >>= fun setup -> + let log = Log.create () in + Future.Scheduler.go ~log + (Main.setup ~log common >>= fun setup -> let context = match List.find setup.contexts ~f:(fun c -> c.name = context) with | Some ctx -> ctx diff --git a/src/future.ml b/src/future.ml index 527c202b..0c6fa885 100644 --- a/src/future.ml +++ b/src/future.ml @@ -304,50 +304,11 @@ module Scheduler = struct ; output_filename : string ; (* for logs, with ansi colors code always included in the string *) command_line : string - ; log : out_channel option + ; log : Log.t } let running = Hashtbl.create 128 - let signal_name = - let table = - let open Sys in - [ sigabrt , "ABRT" - ; sigalrm , "ALRM" - ; sigfpe , "FPE" - ; sighup , "HUP" - ; sigill , "ILL" - ; sigint , "INT" - ; sigkill , "KILL" - ; sigpipe , "PIPE" - ; sigquit , "QUIT" - ; sigsegv , "SEGV" - ; sigterm , "TERM" - ; sigusr1 , "USR1" - ; sigusr2 , "USR2" - ; sigchld , "CHLD" - ; sigcont , "CONT" - ; sigstop , "STOP" - ; sigtstp , "TSTP" - ; sigttin , "TTIN" - ; sigttou , "TTOU" - ; sigvtalrm , "VTALRM" - ; sigprof , "PROF" - (* These ones are only available in OCaml >= 4.03 *) - ; -22 , "BUS" - ; -23 , "POLL" - ; -24 , "SYS" - ; -25 , "TRAP" - ; -26 , "URG" - ; -27 , "XCPU" - ; -28 , "XFSZ" - ] - in - fun n -> - match List.assoc n table with - | exception Not_found -> sprintf "%d\n" n - | s -> s - let process_done ?(exiting=false) job (status : Unix.process_status) = Hashtbl.remove running job.pid; let output = @@ -359,17 +320,10 @@ module Scheduler = struct s in Temp.destroy job.output_filename; - Option.iter job.log ~f:(fun oc -> - Printf.fprintf oc "$ %s\n%s" - (Ansi_color.strip job.command_line) - (Ansi_color.strip output); - (match status with - | WEXITED 0 -> () - | WEXITED n -> Printf.fprintf oc "[%d]\n" n - | WSIGNALED n -> Printf.fprintf oc "[got signal %s]\n" (signal_name n) - | WSTOPPED _ -> assert false); - flush oc - ); + Log.command job.log + ~command_line:job.command_line + ~output:output + ~exit_status:status; if not exiting then begin match status with | WEXITED n when List.mem n ~set:job.job.ok_codes -> @@ -390,7 +344,7 @@ module Scheduler = struct | WSIGNALED n -> Format.eprintf "\n@{Command@} [@{%d@}] got signal %s:\n\ @{$@} %s\n%s%!" - job.id (signal_name n) + job.id (Utils.signal_name n) (Ansi_color.strip_colors_for_stderr job.command_line) (Ansi_color.strip_colors_for_stderr output); die "" @@ -511,7 +465,7 @@ module Scheduler = struct end; go_rec cwd log t - let go ?log t = + let go ?(log=Log.no_log) t = Lazy.force Ansi_color.setup_env_for_ocaml_colors; let cwd = Sys.getcwd () in go_rec cwd log t diff --git a/src/future.mli b/src/future.mli index 31a38042..49f56023 100644 --- a/src/future.mli +++ b/src/future.mli @@ -74,7 +74,7 @@ val run_capture_lines -> 'a t module Scheduler : sig - val go : ?log:out_channel -> 'a t -> 'a + val go : ?log:Log.t -> 'a t -> 'a (** Executes [f] before exiting, after all pending commands have finished *) val at_exit_after_waiting_for_commands : (unit -> unit) -> unit diff --git a/src/gen_rules.ml b/src/gen_rules.ml index f79eae5f..2433097f 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -1599,7 +1599,7 @@ module Gen(P : Params) = struct |> function | Ok x -> x | Error (name, f1, f2) -> - die "too many for module %s in %s: %s and %s" + die "too many files for module %s in %s: %s and %s" name (Path.to_string dir) f1 f2 in let impls = parse_one_set ml_files in diff --git a/src/import.ml b/src/import.ml index da2146b0..51ff4245 100644 --- a/src/import.ml +++ b/src/import.ml @@ -253,6 +253,27 @@ module String = struct loop i (j + 1) in loop 0 0 + + let split_lines s = + let rec loop ~last_is_cr i j = + if j = length s then ( + if j = i || (j = i + 1 && last_is_cr) then + [] + else + [sub s ~pos:i ~len:(j - i)] + ) else + match s.[j] with + | '\r' -> loop ~last_is_cr:true i (j + 1) + | '\n' -> + let line = + let len = if last_is_cr then j - i - 1 else j - i in + sub s ~pos:i ~len + in + line :: loop (j + 1) (j + 1) ~last_is_cr:false + | _ -> + loop i (j + 1) ~last_is_cr:false + in + loop 0 0 ~last_is_cr:false end module Filename = struct diff --git a/src/log.ml b/src/log.ml new file mode 100644 index 00000000..4e674be4 --- /dev/null +++ b/src/log.ml @@ -0,0 +1,61 @@ +open Import + +type real = + { oc : out_channel + ; buf : Buffer.t + ; ppf : Format.formatter + } + +type t = real option + +let no_log = None + +let create () = + if not (Sys.file_exists "_build") then + Unix.mkdir "_build" 0o777; + let oc = open_out_bin "_build/log" in + Printf.fprintf oc "# %s\n%!" + (String.concat (List.map (Array.to_list Sys.argv) ~f:quote_for_shell) ~sep:" "); + let buf = Buffer.create 1024 in + let ppf = Format.formatter_of_buffer buf in + 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 info t str = + match t with + | None -> () + | Some t -> info_internal t str + +let infof t fmt = + match t with + | None -> Format.ikfprintf ignore Format.str_formatter fmt + | Some t -> + Format.kfprintf + (fun ppf -> + Format.pp_print_flush ppf (); + let s = Buffer.contents t.buf in + Buffer.clear t.buf; + info_internal t s) + t.ppf + fmt + +let command t ~command_line ~output ~exit_status = + match t with + | None -> () + | Some { oc; _ } -> + Printf.fprintf oc "$ %s\n" (Ansi_color.strip command_line); + List.iter (String.split_lines output) ~f:(fun s -> + match Ansi_color.strip s with + | "" -> output_string oc ">\n" + | s -> Printf.fprintf oc "> %s\n" s); + (match (exit_status : Unix.process_status) with + | WEXITED 0 -> () + | WEXITED n -> Printf.fprintf oc "[%d]\n" n + | WSIGNALED n -> Printf.fprintf oc "[got signal %s]\n" (Utils.signal_name n) + | WSTOPPED _ -> assert false); + flush oc diff --git a/src/log.mli b/src/log.mli new file mode 100644 index 00000000..cd1c57d6 --- /dev/null +++ b/src/log.mli @@ -0,0 +1,22 @@ +(** Log file *) + +type t + +val no_log : t + +val create : unit -> t + +(** Print an information message in the log *) +val info : t -> string -> unit +val infof : t -> ('a, Format.formatter, unit, unit) format4 -> 'a + +(** Print an executed command in the log *) +val command + : t + -> command_line:string + -> output:string + -> exit_status:Unix.process_status + -> unit + + + diff --git a/src/main.ml b/src/main.ml index 853c9944..8214ba74 100644 --- a/src/main.ml +++ b/src/main.ml @@ -13,7 +13,7 @@ let package_install_file { packages; _ } pkg = | None -> Error () | Some p -> Ok (Path.relative p.path (p.name ^ ".install")) -let setup ?filter_out_optional_stanzas_with_missing_deps +let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps ?workspace ?(workspace_file="jbuild-workspace") ?only_packages () = let conf = Jbuild_load.load () in @@ -39,6 +39,8 @@ let setup ?filter_out_optional_stanzas_with_missing_deps | Opam { name; switch; root; merlin } -> Context.create_for_opam ~name ~switch ?root ~merlin ())) >>= fun contexts -> + List.iter contexts ~f:(fun ctx -> + Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp (Context.sexp_of_t ctx)); Gen_rules.gen conf ~contexts ?only_packages ?filter_out_optional_stanzas_with_missing_deps @@ -117,14 +119,6 @@ let report_error ?map_fname ppf exn = let backtrace = Printexc.get_raw_backtrace () in report_error ?map_fname ppf exn ~backtrace -let create_log () = - if not (Sys.file_exists "_build") then - Unix.mkdir "_build" 0o777; - let oc = open_out_bin "_build/log" in - Printf.fprintf oc "# %s\n%!" - (String.concat (List.map (Array.to_list Sys.argv) ~f:quote_for_shell) ~sep:" "); - oc - (* Called by the script generated by ../build.ml *) let bootstrap () = Ansi_color.setup_err_formatter_colors (); @@ -137,8 +131,9 @@ let bootstrap () = ; "--debug-rules", Set Clflags.debug_rules , " print out rules" ] anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:"; - Future.Scheduler.go ~log:(create_log ()) - (setup ~workspace:{ merlin_context = Some "default"; contexts = [Default] } () + let log = Log.create () in + Future.Scheduler.go ~log + (setup ~log ~workspace:{ merlin_context = Some "default"; contexts = [Default] } () >>= fun { build_system = bs; _ } -> Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) in diff --git a/src/main.mli b/src/main.mli index 30be0b8d..1fb9213a 100644 --- a/src/main.mli +++ b/src/main.mli @@ -12,19 +12,18 @@ type setup = val package_install_file : setup -> string -> (Path.t, unit) result val setup - : ?filter_out_optional_stanzas_with_missing_deps:bool + : ?log:Log.t + -> ?filter_out_optional_stanzas_with_missing_deps:bool -> ?workspace:Workspace.t -> ?workspace_file:string -> ?only_packages:String_set.t -> unit -> setup Future.t val external_lib_deps - : ?log:out_channel + : ?log:Log.t -> packages:string list -> unit -> Build.lib_deps Path.Map.t val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit val bootstrap : unit -> unit - -val create_log : unit -> out_channel diff --git a/src/sexp.ml b/src/sexp.ml index 65a096ae..8067cc97 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -23,6 +23,26 @@ let rec to_string = function | Atom s -> if must_escape s then sprintf "%S" s else s | List l -> sprintf "(%s)" (List.map l ~f:to_string |> String.concat ~sep:" ") +let rec pp ppf = function + | Atom s -> + if must_escape s then + Format.fprintf ppf "%S" s + else + Format.pp_print_string ppf s + | List [] -> + Format.pp_print_string ppf "()" + | List (first :: rest) -> + Format.pp_open_box ppf 1; + Format.pp_print_string ppf "("; + Format.pp_open_hvbox ppf 0; + pp ppf first; + List.iter rest ~f:(fun sexp -> + Format.pp_print_space ppf (); + pp ppf sexp); + Format.pp_close_box ppf (); + Format.pp_print_string ppf ")"; + Format.pp_close_box ppf () + let code_error message vars = code_errorf "%s" (to_string diff --git a/src/sexp.mli b/src/sexp.mli index 20b37f0f..6cc31f71 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -22,6 +22,8 @@ val code_error : string -> (string * t) list -> _ val to_string : t -> string +val pp : Format.formatter -> t -> unit + module type Combinators = sig type 'a t val unit : unit t diff --git a/src/utils.ml b/src/utils.ml index 93c6b8ec..e61f2b18 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -18,3 +18,42 @@ let system_shell = die "I need %s to %s but I couldn't find it :(\n\ Who doesn't have %s%s?!" cmd needed_to cmd os }) + +let signal_name = + let table = + let open Sys in + [ sigabrt , "ABRT" + ; sigalrm , "ALRM" + ; sigfpe , "FPE" + ; sighup , "HUP" + ; sigill , "ILL" + ; sigint , "INT" + ; sigkill , "KILL" + ; sigpipe , "PIPE" + ; sigquit , "QUIT" + ; sigsegv , "SEGV" + ; sigterm , "TERM" + ; sigusr1 , "USR1" + ; sigusr2 , "USR2" + ; sigchld , "CHLD" + ; sigcont , "CONT" + ; sigstop , "STOP" + ; sigtstp , "TSTP" + ; sigttin , "TTIN" + ; sigttou , "TTOU" + ; sigvtalrm , "VTALRM" + ; sigprof , "PROF" + (* These ones are only available in OCaml >= 4.03 *) + ; -22 , "BUS" + ; -23 , "POLL" + ; -24 , "SYS" + ; -25 , "TRAP" + ; -26 , "URG" + ; -27 , "XCPU" + ; -28 , "XFSZ" + ] + in + fun n -> + match List.assoc n table with + | exception Not_found -> sprintf "%d\n" n + | s -> s diff --git a/src/utils.mli b/src/utils.mli index e54eba93..15b1166d 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -5,3 +5,6 @@ open Import (** Return the absolute path to the shell, the argument to pass it (-c or /c) and a failure in case the shell can't be found. *) val system_shell : needed_to:string -> Path.t * string * fail option + +(** Convert a signal number to a name: INT, TERM, ... *) +val signal_name : int -> string