diff --git a/Makefile b/Makefile index a05685c1..fed56934 100644 --- a/Makefile +++ b/Makefile @@ -234,7 +234,7 @@ testsuite: unit-tests #> reset-tests : Update the expected test results from current run reset-tests: .FORCE $(CLERK_BIN) - $(CLERK_TEST) tests --reset + $(CLERK_TEST) tests doc --reset tests/%: .FORCE $(CLERK_TEST) test $@ diff --git a/compiler/catala_utils/dune b/compiler/catala_utils/dune index b70f05bd..52eb7bf6 100644 --- a/compiler/catala_utils/dune +++ b/compiler/catala_utils/dune @@ -3,7 +3,7 @@ (public_name catala.catala_utils) (modules (:standard \ get_version)) - (libraries unix cmdliner ubase ocolor re bindlib catala.runtime_ocaml)) + (libraries unix cmdliner ubase ocolor re)) (executable (name get_version) diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index 6c9d7985..ff7cdcaa 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -180,6 +180,42 @@ let process_out ?check_exit cmd args = assert false with End_of_file -> Buffer.contents buf +(* SIDE EFFECT AT MODULE LOAD: sets up a signal handler on SIGWINCH (window + resize) *) +let () = + let default = 80 in + let get_terminal_cols () = + let count = + try (* terminfo *) + process_out "tput" ["cols"] |> int_of_string + with Failure _ -> ( + try + (* stty *) + process_out "stty" ["size"] + |> fun s -> + let i = String.rindex s ' ' + 1 in + String.sub s (i + 1) (String.length s - i) |> int_of_string + with Failure _ | Not_found | Invalid_argument _ -> ( + try int_of_string (Sys.getenv "COLUMNS") + with Not_found | Failure _ -> 0)) + in + if count > 0 then count else default + in + let width = ref None in + let () = + try + Sys.set_signal 28 (* SIGWINCH *) + (Sys.Signal_handle (fun _ -> width := None)) + with Invalid_argument _ -> () + in + Message.set_terminal_width_function (fun () -> + match !width with + | Some n -> n + | None -> + let r = get_terminal_cols () in + width := Some r; + r) + let check_directory d = try let d = Unix.realpath d in diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index 47656321..4c4abe58 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -34,22 +34,39 @@ let unstyle_formatter ppf = [Format.sprintf] etc. functions (ignoring them) *) let () = ignore (unstyle_formatter Format.str_formatter) +let terminal_columns, set_terminal_width_function = + let get_cols = ref (fun () -> 80) in + (fun () -> !get_cols ()), fun f -> get_cols := f + (* Note: we could do the same for std_formatter, err_formatter... but we'd rather promote the use of the formatting functions of this module and the below std_ppf / err_ppf *) -let has_color oc = +let has_color_raw ~(tty : bool Lazy.t) = match Global.options.color with | Global.Never -> false | Always -> true - | Auto -> Unix.(isatty (descr_of_out_channel oc)) + | Auto -> Lazy.force tty + +let has_color oc = + has_color_raw ~tty:(lazy Unix.(isatty (descr_of_out_channel oc))) (* Here we create new formatters to stderr/stdout that remain separate from the ones used by [Format.printf] / [Format.eprintf] (which remain unchanged) *) let formatter_of_out_channel oc = + let tty = lazy Unix.(isatty (descr_of_out_channel oc)) in let ppf = Format.formatter_of_out_channel oc in - if has_color oc then color_formatter ppf else unstyle_formatter ppf + let ppf = + if has_color_raw ~tty then color_formatter ppf else unstyle_formatter ppf + in + let out, flush = Format.pp_get_formatter_output_functions ppf () in + let flush () = + if Lazy.force tty then Format.pp_set_margin ppf (terminal_columns ()); + flush () + in + Format.pp_set_formatter_output_functions ppf out flush; + ppf let std_ppf = lazy (formatter_of_out_channel stdout) let err_ppf = lazy (formatter_of_out_channel stderr) diff --git a/compiler/catala_utils/message.mli b/compiler/catala_utils/message.mli index b4b9581e..1ef32a72 100644 --- a/compiler/catala_utils/message.mli +++ b/compiler/catala_utils/message.mli @@ -71,6 +71,7 @@ val unformat : (Format.formatter -> unit) -> string indents *) val has_color : out_channel -> bool +val set_terminal_width_function : (unit -> int) -> unit (* {1 More general color-enabled formatting helpers}*)