From 791ae3229b8fd90f8d71e7ac20c51787f722b890 Mon Sep 17 00:00:00 2001
From: Louis Gesbert <louis.gesbert@ocamlpro.com>
Date: Fri, 26 Apr 2024 15:40:55 +0200
Subject: [PATCH] Messages: adjust to terminal width

---
 Makefile                          |  2 +-
 compiler/catala_utils/dune        |  2 +-
 compiler/catala_utils/file.ml     | 36 +++++++++++++++++++++++++++++++
 compiler/catala_utils/message.ml  | 23 +++++++++++++++++---
 compiler/catala_utils/message.mli |  1 +
 5 files changed, 59 insertions(+), 5 deletions(-)

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