CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-20 00:41:05 +03:00
Code Issues Projects Releases Wiki Activity

Fix adjustment of format width to terminal

Browse Source
This commit is contained in:
Louis Gesbert 2024-05-04 17:45:22 +02:00
parent 0ee512b832
commit 3d1e9a56bf
3 changed files with 25 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
compiler/catala_utils/file.ml
View File

@ -114,7 +114,7 @@ let with_in_channel filename f =
finally (fun () -> close_in oc) (fun () -> f oc) finally (fun () -> close_in oc) (fun () -> f oc)
let with_formatter_of_out_channel oc f = let with_formatter_of_out_channel oc f =
let fmt = Message.formatter_of_out_channel oc in let fmt = Message.formatter_of_out_channel oc () in
finally (fun () -> Format.pp_print_flush fmt ()) @@ fun () -> f fmt finally (fun () -> Format.pp_print_flush fmt ()) @@ fun () -> f fmt
let with_formatter_of_file filename f = let with_formatter_of_file filename f =
@ -186,15 +186,17 @@ let () =
let default = 80 in let default = 80 in
let get_terminal_cols () = let get_terminal_cols () =
let count = let count =
try (* terminfo *) try
process_out "tput" ["cols"] |> int_of_string (* terminfo *)
process_out "tput" ["cols"] |> String.trim |> int_of_string
with Failure _ -> ( with Failure _ -> (
try try
(* stty *) (* stty *)
process_out "stty" ["size"] process_out "stty" ["size"]
|> String.trim
|> fun s -> |> fun s ->
let i = String.rindex s ' ' + 1 in let i = String.rindex s ' ' + 1 in
String.sub s (i + 1) (String.length s - i) |> int_of_string String.sub s i (String.length s - i) |> int_of_string
with Failure _ | Not_found | Invalid_argument _ -> ( with Failure _ | Not_found | Invalid_argument _ -> (
try int_of_string (Sys.getenv "COLUMNS") try int_of_string (Sys.getenv "COLUMNS")
with Not_found | Failure _ -> 0)) with Not_found | Failure _ -> 0))

33
compiler/catala_utils/message.ml
View File

@ -56,21 +56,22 @@ let has_color oc =
let formatter_of_out_channel oc = let formatter_of_out_channel oc =
let tty = lazy Unix.(isatty (descr_of_out_channel oc)) in let tty = lazy Unix.(isatty (descr_of_out_channel oc)) in
let ppf = Format.formatter_of_out_channel oc in
let ppf = let ppf =
if has_color_raw ~tty then color_formatter ppf else unstyle_formatter ppf lazy
(let ppf = Format.formatter_of_out_channel oc in
if has_color_raw ~tty then color_formatter ppf else unstyle_formatter ppf)
in in
let out, flush = Format.pp_get_formatter_output_functions ppf () in fun () ->
let flush () = let ppf = Lazy.force ppf in
if Lazy.force tty then Format.pp_set_margin ppf (terminal_columns ()); if Lazy.force tty then Format.pp_set_margin ppf (terminal_columns ());
flush ()
in
Format.pp_set_formatter_output_functions ppf out flush;
ppf ppf
let std_ppf = lazy (formatter_of_out_channel stdout) let std_ppf = formatter_of_out_channel stdout
let err_ppf = lazy (formatter_of_out_channel stderr) let err_ppf = formatter_of_out_channel stderr
let ignore_ppf = lazy (Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()))
let ignore_ppf =
let ppf = lazy (Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())) in
fun () -> Lazy.force ppf
let unformat (f : Format.formatter -> unit) : string = let unformat (f : Format.formatter -> unit) : string =
let buf = Buffer.create 1024 in let buf = Buffer.create 1024 in
@ -94,10 +95,10 @@ let unformat (f : Format.formatter -> unit) : string =
type level = Error | Warning | Debug | Log | Result type level = Error | Warning | Debug | Log | Result
let get_ppf = function let get_ppf = function
| Result -> Lazy.force std_ppf | Result -> std_ppf ()
| Debug when not Global.options.debug -> Lazy.force ignore_ppf | Debug when not Global.options.debug -> ignore_ppf ()
| Warning when Global.options.disable_warnings -> Lazy.force ignore_ppf | Warning when Global.options.disable_warnings -> ignore_ppf ()
| Error | Log | Debug | Warning -> Lazy.force err_ppf | Error | Log | Debug | Warning -> err_ppf ()
(**{3 Markers}*) (**{3 Markers}*)
@ -354,9 +355,9 @@ let make
~level = ~level =
match level with match level with
| Debug when not Global.options.debug -> | Debug when not Global.options.debug ->
Format.ikfprintf (fun _ -> cont [] level) (Lazy.force ignore_ppf) Format.ikfprintf (fun _ -> cont [] level) (ignore_ppf ())
| Warning when Global.options.disable_warnings -> | Warning when Global.options.disable_warnings ->
Format.ikfprintf (fun _ -> cont [] level) (Lazy.force ignore_ppf) Format.ikfprintf (fun _ -> cont [] level) (ignore_ppf ())
| _ -> | _ ->
Format.kdprintf Format.kdprintf
@@ fun message -> @@ fun message ->

2
compiler/catala_utils/message.mli
View File

@ -75,7 +75,7 @@ val set_terminal_width_function : (unit -> int) -> unit
(* {1 More general color-enabled formatting helpers}*) (* {1 More general color-enabled formatting helpers}*)
val formatter_of_out_channel : out_channel -> Format.formatter val formatter_of_out_channel : out_channel -> unit -> Format.formatter
(** Creates a new formatter from the given out channel, with correct handling of (** Creates a new formatter from the given out channel, with correct handling of
the ocolor tags. Actual use of escape codes in the output depends on the ocolor tags. Actual use of escape codes in the output depends on
[Cli.style_flag] -- and wether the channel is a tty if that is set to auto. *) [Cli.style_flag] -- and wether the channel is a tty if that is set to auto. *)