Messages: adjust to terminal width

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 $@

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)

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

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)

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}*)