Add a Log module and print out the context in the log file
This commit is contained in:
parent
563cc6059c
commit
d959b0f928
32
bin/main.ml
32
bin/main.ml
|
@ -37,8 +37,9 @@ let set_common c =
|
||||||
module Main = struct
|
module Main = struct
|
||||||
include Jbuilder.Main
|
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
|
setup
|
||||||
|
~log
|
||||||
?workspace_file:common.workspace_file
|
?workspace_file:common.workspace_file
|
||||||
?only_packages:common.only_packages
|
?only_packages:common.only_packages
|
||||||
?filter_out_optional_stanzas_with_missing_deps ()
|
?filter_out_optional_stanzas_with_missing_deps ()
|
||||||
|
@ -47,8 +48,6 @@ end
|
||||||
let do_build (setup : Main.setup) targets =
|
let do_build (setup : Main.setup) targets =
|
||||||
Build_system.do_build_exn setup.build_system targets
|
Build_system.do_build_exn setup.build_system targets
|
||||||
|
|
||||||
let create_log = Main.create_log
|
|
||||||
|
|
||||||
type ('a, 'b) walk_result =
|
type ('a, 'b) walk_result =
|
||||||
| Cont of 'a
|
| Cont of 'a
|
||||||
| Stop of 'b
|
| Stop of 'b
|
||||||
|
@ -220,7 +219,7 @@ let installed_libraries =
|
||||||
let doc = "Print out libraries installed on the system." in
|
let doc = "Print out libraries installed on the system." in
|
||||||
let go common =
|
let go common =
|
||||||
set_common common;
|
set_common common;
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
Future.Scheduler.go ~log:(Log.create ())
|
||||||
(Context.default () >>= fun ctx ->
|
(Context.default () >>= fun ctx ->
|
||||||
let findlib = ctx.findlib in
|
let findlib = ctx.findlib in
|
||||||
let pkgs = Findlib.all_packages findlib in
|
let pkgs = Findlib.all_packages findlib in
|
||||||
|
@ -318,8 +317,9 @@ let build_targets =
|
||||||
let name_ = Arg.info [] ~docv:"TARGET" in
|
let name_ = Arg.info [] ~docv:"TARGET" in
|
||||||
let go common targets =
|
let go common targets =
|
||||||
set_common common;
|
set_common common;
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
let log = Log.create () in
|
||||||
(Main.setup common >>= fun setup ->
|
Future.Scheduler.go ~log
|
||||||
|
(Main.setup ~log common >>= fun setup ->
|
||||||
let targets = resolve_targets common setup targets in
|
let targets = resolve_targets common setup targets in
|
||||||
do_build setup targets) in
|
do_build setup targets) in
|
||||||
( Term.(const go
|
( Term.(const go
|
||||||
|
@ -339,8 +339,9 @@ let runtest =
|
||||||
let name_ = Arg.info [] ~docv:"DIR" in
|
let name_ = Arg.info [] ~docv:"DIR" in
|
||||||
let go common dirs =
|
let go common dirs =
|
||||||
set_common common;
|
set_common common;
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
let log = Log.create () in
|
||||||
(Main.setup common >>= fun setup ->
|
Future.Scheduler.go ~log
|
||||||
|
(Main.setup ~log common >>= fun setup ->
|
||||||
let targets =
|
let targets =
|
||||||
List.map dirs ~f:(fun dir ->
|
List.map dirs ~f:(fun dir ->
|
||||||
let dir = Path.(relative root) (prefix_target common dir) in
|
let dir = Path.(relative root) (prefix_target common dir) in
|
||||||
|
@ -364,8 +365,9 @@ let external_lib_deps =
|
||||||
in
|
in
|
||||||
let go common only_missing targets =
|
let go common only_missing targets =
|
||||||
set_common common;
|
set_common common;
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
let log = Log.create () in
|
||||||
(Main.setup common ~filter_out_optional_stanzas_with_missing_deps:false
|
Future.Scheduler.go ~log
|
||||||
|
(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 common setup targets in
|
||||||
let failure =
|
let failure =
|
||||||
|
@ -456,8 +458,9 @@ let install_uninstall ~what =
|
||||||
let go common prefix pkgs =
|
let go common prefix pkgs =
|
||||||
set_common common;
|
set_common common;
|
||||||
let opam_installer = opam_installer () in
|
let opam_installer = opam_installer () in
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
let log = Log.create () in
|
||||||
(Main.setup common >>= fun setup ->
|
Future.Scheduler.go ~log
|
||||||
|
(Main.setup ~log common >>= fun setup ->
|
||||||
let pkgs =
|
let pkgs =
|
||||||
match pkgs with
|
match pkgs with
|
||||||
| [] -> String_map.keys setup.packages
|
| [] -> String_map.keys setup.packages
|
||||||
|
@ -526,8 +529,9 @@ let exec =
|
||||||
in
|
in
|
||||||
let go common context prog args =
|
let go common context prog args =
|
||||||
set_common common;
|
set_common common;
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
let log = Log.create () in
|
||||||
(Main.setup common >>= fun setup ->
|
Future.Scheduler.go ~log
|
||||||
|
(Main.setup ~log common >>= fun setup ->
|
||||||
let context =
|
let context =
|
||||||
match List.find setup.contexts ~f:(fun c -> c.name = context) with
|
match List.find setup.contexts ~f:(fun c -> c.name = context) with
|
||||||
| Some ctx -> ctx
|
| Some ctx -> ctx
|
||||||
|
|
|
@ -304,50 +304,11 @@ module Scheduler = struct
|
||||||
; output_filename : string
|
; output_filename : string
|
||||||
; (* for logs, with ansi colors code always included in the string *)
|
; (* for logs, with ansi colors code always included in the string *)
|
||||||
command_line : string
|
command_line : string
|
||||||
; log : out_channel option
|
; log : Log.t
|
||||||
}
|
}
|
||||||
|
|
||||||
let running = Hashtbl.create 128
|
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) =
|
let process_done ?(exiting=false) job (status : Unix.process_status) =
|
||||||
Hashtbl.remove running job.pid;
|
Hashtbl.remove running job.pid;
|
||||||
let output =
|
let output =
|
||||||
|
@ -359,17 +320,10 @@ module Scheduler = struct
|
||||||
s
|
s
|
||||||
in
|
in
|
||||||
Temp.destroy job.output_filename;
|
Temp.destroy job.output_filename;
|
||||||
Option.iter job.log ~f:(fun oc ->
|
Log.command job.log
|
||||||
Printf.fprintf oc "$ %s\n%s"
|
~command_line:job.command_line
|
||||||
(Ansi_color.strip job.command_line)
|
~output:output
|
||||||
(Ansi_color.strip output);
|
~exit_status:status;
|
||||||
(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
|
|
||||||
);
|
|
||||||
if not exiting then begin
|
if not exiting then begin
|
||||||
match status with
|
match status with
|
||||||
| WEXITED n when List.mem n ~set:job.job.ok_codes ->
|
| WEXITED n when List.mem n ~set:job.job.ok_codes ->
|
||||||
|
@ -390,7 +344,7 @@ module Scheduler = struct
|
||||||
| WSIGNALED n ->
|
| WSIGNALED n ->
|
||||||
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] got signal %s:\n\
|
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] got signal %s:\n\
|
||||||
@{<prompt>$@} %s\n%s%!"
|
@{<prompt>$@} %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 job.command_line)
|
||||||
(Ansi_color.strip_colors_for_stderr output);
|
(Ansi_color.strip_colors_for_stderr output);
|
||||||
die ""
|
die ""
|
||||||
|
@ -511,7 +465,7 @@ module Scheduler = struct
|
||||||
end;
|
end;
|
||||||
go_rec cwd log t
|
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;
|
Lazy.force Ansi_color.setup_env_for_ocaml_colors;
|
||||||
let cwd = Sys.getcwd () in
|
let cwd = Sys.getcwd () in
|
||||||
go_rec cwd log t
|
go_rec cwd log t
|
||||||
|
|
|
@ -74,7 +74,7 @@ val run_capture_lines
|
||||||
-> 'a t
|
-> 'a t
|
||||||
|
|
||||||
module Scheduler : sig
|
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 *)
|
(** Executes [f] before exiting, after all pending commands have finished *)
|
||||||
val at_exit_after_waiting_for_commands : (unit -> unit) -> unit
|
val at_exit_after_waiting_for_commands : (unit -> unit) -> unit
|
||||||
|
|
|
@ -1599,7 +1599,7 @@ module Gen(P : Params) = struct
|
||||||
|> function
|
|> function
|
||||||
| Ok x -> x
|
| Ok x -> x
|
||||||
| Error (name, f1, f2) ->
|
| 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
|
name (Path.to_string dir) f1 f2
|
||||||
in
|
in
|
||||||
let impls = parse_one_set ml_files in
|
let impls = parse_one_set ml_files in
|
||||||
|
|
|
@ -253,6 +253,27 @@ module String = struct
|
||||||
loop i (j + 1)
|
loop i (j + 1)
|
||||||
in
|
in
|
||||||
loop 0 0
|
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
|
end
|
||||||
|
|
||||||
module Filename = struct
|
module Filename = struct
|
||||||
|
|
|
@ -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
|
|
@ -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
|
||||||
|
|
||||||
|
|
||||||
|
|
17
src/main.ml
17
src/main.ml
|
@ -13,7 +13,7 @@ let package_install_file { packages; _ } pkg =
|
||||||
| None -> Error ()
|
| None -> Error ()
|
||||||
| Some p -> Ok (Path.relative p.path (p.name ^ ".install"))
|
| 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")
|
?workspace ?(workspace_file="jbuild-workspace")
|
||||||
?only_packages () =
|
?only_packages () =
|
||||||
let conf = Jbuild_load.load () in
|
let conf = Jbuild_load.load () in
|
||||||
|
@ -39,6 +39,8 @@ let setup ?filter_out_optional_stanzas_with_missing_deps
|
||||||
| Opam { name; switch; root; merlin } ->
|
| Opam { name; switch; root; merlin } ->
|
||||||
Context.create_for_opam ~name ~switch ?root ~merlin ()))
|
Context.create_for_opam ~name ~switch ?root ~merlin ()))
|
||||||
>>= fun contexts ->
|
>>= 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
|
Gen_rules.gen conf ~contexts
|
||||||
?only_packages
|
?only_packages
|
||||||
?filter_out_optional_stanzas_with_missing_deps
|
?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
|
let backtrace = Printexc.get_raw_backtrace () in
|
||||||
report_error ?map_fname ppf exn ~backtrace
|
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 *)
|
(* Called by the script generated by ../build.ml *)
|
||||||
let bootstrap () =
|
let bootstrap () =
|
||||||
Ansi_color.setup_err_formatter_colors ();
|
Ansi_color.setup_err_formatter_colors ();
|
||||||
|
@ -137,8 +131,9 @@ let bootstrap () =
|
||||||
; "--debug-rules", Set Clflags.debug_rules , " print out rules"
|
; "--debug-rules", Set Clflags.debug_rules , " print out rules"
|
||||||
]
|
]
|
||||||
anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
|
anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
let log = Log.create () in
|
||||||
(setup ~workspace:{ merlin_context = Some "default"; contexts = [Default] } ()
|
Future.Scheduler.go ~log
|
||||||
|
(setup ~log ~workspace:{ merlin_context = Some "default"; contexts = [Default] } ()
|
||||||
>>= fun { build_system = bs; _ } ->
|
>>= fun { build_system = bs; _ } ->
|
||||||
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
|
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
|
||||||
in
|
in
|
||||||
|
|
|
@ -12,19 +12,18 @@ type setup =
|
||||||
val package_install_file : setup -> string -> (Path.t, unit) result
|
val package_install_file : setup -> string -> (Path.t, unit) result
|
||||||
|
|
||||||
val setup
|
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:Workspace.t
|
||||||
-> ?workspace_file:string
|
-> ?workspace_file:string
|
||||||
-> ?only_packages:String_set.t
|
-> ?only_packages:String_set.t
|
||||||
-> unit
|
-> unit
|
||||||
-> setup Future.t
|
-> setup Future.t
|
||||||
val external_lib_deps
|
val external_lib_deps
|
||||||
: ?log:out_channel
|
: ?log:Log.t
|
||||||
-> packages:string list
|
-> packages:string list
|
||||||
-> unit
|
-> unit
|
||||||
-> Build.lib_deps Path.Map.t
|
-> Build.lib_deps Path.Map.t
|
||||||
val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit
|
val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit
|
||||||
|
|
||||||
val bootstrap : unit -> unit
|
val bootstrap : unit -> unit
|
||||||
|
|
||||||
val create_log : unit -> out_channel
|
|
||||||
|
|
20
src/sexp.ml
20
src/sexp.ml
|
@ -23,6 +23,26 @@ let rec to_string = function
|
||||||
| Atom s -> if must_escape s then sprintf "%S" s else s
|
| 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:" ")
|
| 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 =
|
let code_error message vars =
|
||||||
code_errorf "%s"
|
code_errorf "%s"
|
||||||
(to_string
|
(to_string
|
||||||
|
|
|
@ -22,6 +22,8 @@ val code_error : string -> (string * t) list -> _
|
||||||
|
|
||||||
val to_string : t -> string
|
val to_string : t -> string
|
||||||
|
|
||||||
|
val pp : Format.formatter -> t -> unit
|
||||||
|
|
||||||
module type Combinators = sig
|
module type Combinators = sig
|
||||||
type 'a t
|
type 'a t
|
||||||
val unit : unit t
|
val unit : unit t
|
||||||
|
|
39
src/utils.ml
39
src/utils.ml
|
@ -18,3 +18,42 @@ let system_shell =
|
||||||
die "I need %s to %s but I couldn't find it :(\n\
|
die "I need %s to %s but I couldn't find it :(\n\
|
||||||
Who doesn't have %s%s?!"
|
Who doesn't have %s%s?!"
|
||||||
cmd needed_to cmd os })
|
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
|
||||||
|
|
|
@ -5,3 +5,6 @@ open Import
|
||||||
(** Return the absolute path to the shell, the argument to pass it (-c or /c) and a
|
(** 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. *)
|
failure in case the shell can't be found. *)
|
||||||
val system_shell : needed_to:string -> Path.t * string * fail option
|
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
|
||||||
|
|
Loading…
Reference in New Issue