Correctly setup ocolor on all output channels

(and some cleanup of the remaining deps to ANSITerminal)

build_release.sh

@@ -18,7 +18,6 @@ CUSTOM_LINKING_CATALA_Z3="\
  -cclib -lzarith
  -cclib -lgmp
  -cclib -lcamlstr
- -cclib -lANSITerminal_stubs
  -cclib -lalcotest_stubs
  -cclib -lunix)"
 

build_system/dune

@@ -13,7 +13,7 @@
   ninja_utils
   cmdliner
   re
-  ANSITerminal)
+  ocolor)
  (modules clerk_driver))
 
 (rule

catala.opam

@@ -18,7 +18,7 @@ license: "Apache-2.0"
 homepage: "https://github.com/CatalaLang/catala"
 bug-reports: "https://github.com/CatalaLang/catala/issues"
 depends: [
-  "ANSITerminal" {>= "0.8.2"}
+  "ocolor" {>= "1.3.0"}
   "benchmark" {>= "1.6"}
   "bindlib" {>= "5.0.1"}
   "cmdliner" {>= "1.1.0"}

clerk.opam

@@ -14,7 +14,7 @@ depends: [
   "ocaml" {>= "4.11.0"}
   "cmdliner" {>= "1.1.0"}
   "re" {>= "1.9.0"}
-  "ANSITerminal" {>= "0.8.2"}
+  "ocolor" {>= "1.3.0"}
   "alcotest" {with-test & >= "1.5.0"}
   "catala" {= version}
   "ninja_utils" {= version}

compiler/catala_utils/cli.ml

@@ -474,43 +474,3 @@ let info =
   in
   let exits = Cmd.Exit.defaults @ [Cmd.Exit.info ~doc:"on error." 1] in
   Cmd.info "catala" ~version ~doc ~exits ~man
-
-(* let with_style
- *     (styles : ANSITerminal.style list)
- *     (str : ('a, unit, string) format) =
- *   if !style_flag then ANSITerminal.sprintf styles str else Printf.sprintf str
- * 
- * let format_with_style (styles : ANSITerminal.style list) fmt (str : string) =
- *   if !style_flag then
- *     Format.pp_print_as fmt (String.length str)
- *       (ANSITerminal.sprintf styles "%s" str)
- *   else Format.pp_print_string fmt str
- * 
- * let call_unstyled f =
- *   let prev = !style_flag in
- *   style_flag := false;
- *   let res = f () in
- *   style_flag := prev;
- *   res
- * 
- * let concat_with_line_depending_prefix_and_suffix
- *     (prefix : int -> string)
- *     (suffix : int -> string)
- *     (ss : string list) =
- *   match ss with
- *   | [] -> prefix 0
- *   | _ :: _ ->
- *     let len = List.length ss in
- *     let suffix i = if i < len - 1 then suffix i else "" in
- *     String.concat ""
- *     @@ List.concat
- *     @@ List.mapi
- *          (fun i s -> [prefix i; (if s = "" then "" else " "); s; suffix i])
- *          ss
- * 
- * (\** The int argument of the prefix corresponds to the line number, starting at 0 *\)
- * let add_prefix_to_each_line (s : string) (prefix : int -> string) =
- *   concat_with_line_depending_prefix_and_suffix
- *     (fun i -> prefix i)
- *     (fun _ -> "\n")
- *     (String.split_on_char '\n' s) *)

compiler/catala_utils/file.ml

@@ -41,7 +41,7 @@ let with_in_channel filename f =
   finally (fun () -> close_in oc) (fun () -> f oc)
 
 let with_formatter_of_out_channel oc f =
-  let fmt = Format.formatter_of_out_channel oc in
+  let fmt = Messages.formatter_of_out_channel oc in
   finally (fun () -> Format.pp_print_flush fmt ()) @@ fun () -> f fmt
 
 let with_formatter_of_file filename f =

compiler/catala_utils/messages.ml

@@ -3,7 +3,7 @@
 (**{1 Terminal formatting}*)
 
 (* Adds handling of color tags in the formatter *)
-let[@ocaml.warning "-32"] color_formatter ppf =
+let color_formatter ppf =
   Ocolor_format.prettify_formatter ppf;
   ppf
 
@@ -23,30 +23,26 @@ let unstyle_formatter ppf =
 (* SIDE EFFECT AT MODULE LOAD: this turns on handling of tags in
    [Format.sprintf] etc. functions (ignoring them) *)
 let () = ignore (unstyle_formatter Format.str_formatter)
+
 (* 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 unix_fd =
+let has_color oc =
   match !Cli.style_flag with
   | Cli.Never -> false
   | Always -> true
-  | Auto -> Unix.isatty unix_fd
+  | Auto -> Unix.(isatty (descr_of_out_channel oc))
 
-(* Here we affect the Ocolor printers to stderr/stdout, which remain separate
+(* Here we create new formatters to stderr/stdout that remain separate from the
-   from the ones used by [Format.printf] / [Format.eprintf] (which remain
+   ones used by [Format.printf] / [Format.eprintf] (which remain unchanged) *)
-   unchanged) *)
 
-let std_ppf =
+let formatter_of_out_channel oc =
-  lazy
+  let ppf = Format.formatter_of_out_channel oc in
-    (if has_color Unix.stdout then Ocolor_format.raw_std_formatter
+  if has_color oc then color_formatter ppf else unstyle_formatter ppf
-    else unstyle_formatter Ocolor_format.raw_std_formatter)
-
-let err_ppf =
-  lazy
-    (if has_color Unix.stderr then Ocolor_format.raw_err_formatter
-    else unstyle_formatter Ocolor_format.raw_err_formatter)
 
+let std_ppf = lazy (formatter_of_out_channel stdout)
+let err_ppf = lazy (formatter_of_out_channel stderr)
 let ignore_ppf = lazy (Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()))
 
 let unformat (f : Format.formatter -> unit) : string =

compiler/catala_utils/messages.mli

@@ -92,22 +92,19 @@ val emit_log : ('a, Format.formatter, unit) format -> 'a
 
 val emit_debug : ('a, Format.formatter, unit) format -> 'a
 
-(* {1 Common result emission}*)
+(** {1 Common result emission}*)
 
 val emit_result : ('a, Format.formatter, unit) format -> 'a
 
-(* {1 Some formatting helpers}*)
+(** {1 Some formatting helpers}*)
 
 val unformat : (Format.formatter -> unit) -> string
-(* Converts [f] to a string, discarding formatting and skipping newlines and
+(** Converts [f] to a string, discarding formatting and skipping newlines and
-   indents *)
+    indents *)
 
-(* (**{2 Markers}*)
+(* {1 More general color-enabled formatting helpers}*)
 
-   val with_style : ANSITerminal.style list -> ('a, unit, string) format -> 'a
+val formatter_of_out_channel : out_channel -> Format.formatter
-
+(** Creates a new formatter from the given out channel, with correct handling of
-   val format_with_style : ANSITerminal.style list -> Format.formatter -> string
+    the ocolor tags. Actual use of escape codes in the output depends on
-   -> unit
+    [Cli.style_flag] -- and wether the channel is a tty if that is set to auto. *)
-
-   val call_unstyled : (unit -> 'a) -> 'a (** [call_unstyled f] calls the
-   function [f] with the [style_flag] set to false during the execution. *) *)

french_law/catala_legifrance/catala_legifrance.ml

@@ -113,20 +113,16 @@ let compare_to_versions
     (law_article_text : law_article_text)
     (access_token : Api.access_token) : unit Lwt.t =
   let print_diff msg diff =
-    Messages.emit_warning "%s\n%s" msg
+    Messages.emit_warning "@[<v>%s@,%a@]" msg
-      (String.concat "\n"
+      (Format.pp_print_list (fun ppf chunk ->
-         (List.map
+           match chunk with
-            (fun chunk ->
+           | Diff.Equal words ->
-              match chunk with
+             Format.fprintf ppf "    %s" (String.concat " " words)
-              | Diff.Equal words ->
+           | Diff.Added words ->
-                ANSITerminal.sprintf [] "    %s" (String.concat " " words)
+             Format.fprintf ppf "@{<green>(+) %s@}" (String.concat " " words)
-              | Diff.Added words ->
+           | Diff.Deleted words ->
-                ANSITerminal.sprintf [ANSITerminal.green] "(+) %s"
+             Format.fprintf ppf "@{<red>(-) %s@}" (String.concat " " words)))
-                  (String.concat " " words)
+      diff
-              | Diff.Deleted words ->
-                ANSITerminal.sprintf [ANSITerminal.red] "(-) %s"
-                  (String.concat " " words))
-            diff))
   in
   let* _checl =
     match law_article_text.current_version with

french_law/catala_legifrance/dune

@@ -10,7 +10,7 @@
   cohttp-lwt-unix
   yojson
   re
-  ANSITerminal))
+  ocolor))
 
 (documentation
  (package catala_legifrance))

french_law/ocaml/law_source/unit_tests/dune

@@ -1,7 +1,7 @@
 (executable
  (name run_tests)
  (modes native)
- (libraries catala.runtime_ocaml ANSITerminal))
+ (libraries catala.runtime_ocaml ocolor))
 
 (copy_files#
  ../../../../examples/allocations_familiales/tests/tests_allocations_familiales.ml)

french_law/ocaml/law_source/unit_tests/run_tests.ml

@@ -3,14 +3,10 @@ let failure = ref false
 let try_test msg test =
   try
     test ();
-    Format.printf "%s %s\n"
+    Format.printf "@{<green>PASS@} @{<magenta>%s@}\n" msg
-      (ANSITerminal.sprintf [ANSITerminal.green] "PASS")
-      (ANSITerminal.sprintf [ANSITerminal.magenta] msg)
   with Runtime_ocaml.Runtime.AssertionFailed _ ->
     failure := true;
-    Format.printf "%s %s\n"
+    Format.printf "@{<red>FAIL@} @{<magenta>%s@}\n" msg
-      (ANSITerminal.sprintf [ANSITerminal.red] "FAIL")
-      (ANSITerminal.sprintf [ANSITerminal.magenta] msg)
 
 let _ =
   try_test "Allocations familiales #1" Tests_allocations_familiales.test1;