Final refactoring of text styling

Text styling contains the functions that allow to prettify a formatter and add
semantic tags marking or printing to a formatter

Each semantic tag handler module should implement its own marker that will then
be used by Terminal_styling from a list of options that need to be applied

backend/native/run.ml

@@ -128,7 +128,7 @@ let update_terminal_width () =
   with
   | _ -> ()
 
-let ansi_terminal () =
+let ansi_terminal l =
   if
     !color
     &&
@@ -137,10 +137,10 @@ let ansi_terminal () =
     | (exception Not_found) ->
         false
     | _ -> true
-  then Ansi_terminal.marker
-  else TextStyling.Empty
+  then `ANSI :: l
+  else l
 
-let prettify () = !prettify
+let prettify l = if !prettify then `UTF8 :: l else []
 
 let setup_term_watcher () =
   if Sys.os_type <> "Unix" && Sys.os_type <> "Cygwin" then ()
@@ -259,14 +259,12 @@ let toploop () =
 
 let main () =
   parse_argv ();
-  let marker = ansi_terminal () in
   let assoc =
     [
       (* Euclidian Products *)
       ("->", Pretty_utf8.create 0x2192 (* → *));
       ("Empty", Pretty_utf8.create 0x01D7D8 (* 𝟘 *));
       ("Any", Pretty_utf8.create 0x01D7D9 (* 𝟙 *));
-      ("\\\\", Pretty_utf8.create 0x00005C (* \ *));
       ("&", Pretty_utf8.create 0x0022C2 (* ⋂ *));
       ("|", Pretty_utf8.create 0x0022C3 (* ⋃ *));
       (* Type Variables *)
@@ -285,10 +283,9 @@ let main () =
     ]
   in
   List.iter (fun (s, sym) -> Pretty_utf8.register_utf8_binding s sym) assoc;
-  TextStyling.add_stag_handlers marker ~prettify:(prettify ())
-    Format.std_formatter;
-  TextStyling.add_stag_handlers marker ~prettify:(prettify ())
-    Format.err_formatter;
+  let stylings = [] |> ansi_terminal |> prettify in
+  Terminal_styling.set_formatter stylings Format.std_formatter;
+  Terminal_styling.set_formatter stylings Format.err_formatter;
   at_exit (fun () -> Stats.dump Format.std_formatter);
   Cduce_loc.set_viewport (Html.create false);
   let m = mode () in

tests/sandbox/pretty_test.ml

@@ -19,7 +19,6 @@ let () =
       ("->", Pretty_utf8.create 0x2192 (* → *));
       ("Empty", Pretty_utf8.create 0x01D7D8 (* 𝟘 *));
       ("Any", Pretty_utf8.create 0x01D7D9 (* 𝟙 *));
-      ("\\\\", Pretty_utf8.create 0x00005C (* \ *));
       ("&", Pretty_utf8.create 0x0022C2 (* ⋂ *));
       ("|", Pretty_utf8.create 0x0022C3 (* ⋃ *));
       (* Type Variables *)
@@ -38,10 +37,8 @@ let () =
     ]
   in
   List.iter (fun (s, sym) -> Pretty_utf8.register_utf8_binding s sym) assoc;
-  TextStyling.add_stag_handlers TextStyling.Empty ~prettify:true
-    Format.str_formatter;
-  TextStyling.add_stag_handlers TextStyling.Empty ~prettify:true
-    Format.err_formatter
+  Terminal_styling.set_formatter [ `UTF8 ] Format.str_formatter;
+  Terminal_styling.set_formatter [ `UTF8 ] Format.err_formatter
 
 let test s =
   let t1 = parse_type s in

types/misc/ansi_terminal.ml

@@ -30,10 +30,9 @@ let pp_ansi_value ppf s =
 let enclosing = { enc_open = "\x1B["; enc_close = "m" }
 
 let marker =
-  TextStyling.Mark
-    {
-      open_enclosing = enclosing;
-      close_enclosing = enclosing;
-      pp_stag = pp_ansi_value;
-      pp_sep = (fun ppf () -> Format.fprintf ppf ";");
-    }
+  {
+    open_enclosing = enclosing;
+    close_enclosing = enclosing;
+    pp_stag = pp_ansi_value;
+    pp_sep = (fun ppf () -> Format.fprintf ppf ";");
+  }

types/misc/ansi_terminal.mli

@@ -5,7 +5,7 @@
     - [Format.fprintf ppf "@{<semantic_tag1; semantic_tag2>...@}" ...]
 *)
 
-val marker : TextStyling.stag_marker
+val marker : TextStyling.marker
 (** [marker] will allow {!TextStyling.add_stag_handlers} to add ansi markings to a formatter.
 
     The current handled tags are the following:

types/misc/textStyling.ml

@@ -126,6 +126,7 @@ let empty_string_of_styles ?(close = false) stag =
 
 let prettify_formatter formatter =
   let open Format in
+  pp_set_mark_tags formatter true;
   let old_of = pp_get_formatter_out_functions formatter () in
   let out_string string pos nb_chars =
     let new_string, new_nb_chars =
@@ -134,6 +135,13 @@ let prettify_formatter formatter =
     in
     old_of.out_string new_string pos new_nb_chars
   in
+  let old_fs = Format.pp_get_formatter_stag_functions formatter () in
+  pp_set_formatter_stag_functions formatter
+    {
+      old_fs with
+      mark_open_stag = empty_string_of_styles;
+      mark_close_stag = empty_string_of_styles ~close:true;
+    };
   pp_set_formatter_out_functions formatter { old_of with out_string }
 
 type enclosing = {
@@ -149,61 +157,40 @@ type marker = {
 }
 
 type stag_marker =
-  | Empty
-  | Mark of marker
-  | Print of marker
+  | Mark
+  | Print
 
-let add_stag_handlers marker ~prettify formatter =
-  if prettify then prettify_formatter formatter;
+let add_stag_handlers m_type marker formatter =
   let open Format in
   (* Handle stags as marks (0 length) or prints (normal length) *)
-  (match marker with
-  | Empty -> if prettify then pp_set_mark_tags formatter true
-  | Mark _ -> pp_set_mark_tags formatter true
-  | Print _ -> pp_set_print_tags formatter true);
+  (match m_type with
+  | Mark -> pp_set_mark_tags formatter true
+  | Print -> pp_set_print_tags formatter true);
   let old_fs = pp_get_formatter_stag_functions formatter () in
-  let handlers =
-    match marker with
-    | Mark marker
-    | Print marker ->
-        let open_stag =
-          let close = false in
-          Styling.(
-            create_mark ~close
-              (pp_styles ~close ~enc_open:marker.open_enclosing.enc_open
-                 ~pp_stag:marker.pp_stag
-                 ~enc_close:marker.open_enclosing.enc_close
-                 ~pp_sep:marker.pp_sep))
-        in
-        let close_stag =
-          let close = true in
-          Styling.(
-            create_mark ~close
-              (pp_styles ~close ~enc_open:marker.close_enclosing.enc_open
-                 ~pp_stag:marker.pp_stag
-                 ~enc_close:marker.close_enclosing.enc_close
-                 ~pp_sep:marker.pp_sep))
-        in
-        Some (open_stag, close_stag)
-    | _ -> None
+  let open_stag =
+    let close = false in
+    Styling.(
+      create_mark ~close
+        (pp_styles ~close ~enc_open:marker.open_enclosing.enc_open
+           ~pp_stag:marker.pp_stag ~enc_close:marker.open_enclosing.enc_close
+           ~pp_sep:marker.pp_sep))
   in
-  match (marker, handlers) with
-  | Mark _, Some (open_stag, close_stag) ->
+  let close_stag =
+    let close = true in
+    Styling.(
+      create_mark ~close
+        (pp_styles ~close ~enc_open:marker.close_enclosing.enc_open
+           ~pp_stag:marker.pp_stag ~enc_close:marker.close_enclosing.enc_close
+           ~pp_sep:marker.pp_sep))
+  in
+  match m_type with
+  | Mark ->
       let mark_open_stag = Format.asprintf "%a" open_stag in
       let mark_close_stag = Format.asprintf "%a" close_stag in
       pp_set_formatter_stag_functions formatter
         { old_fs with mark_open_stag; mark_close_stag }
-  | Print _, Some (open_stag, close_stag) ->
+  | Print ->
       let print_open_stag = Format.fprintf formatter "%a" open_stag in
       let print_close_stag = Format.fprintf formatter "%a" close_stag in
       pp_set_formatter_stag_functions formatter
         { old_fs with print_open_stag; print_close_stag }
-  | Empty, None when prettify ->
-      pp_set_formatter_stag_functions formatter
-        {
-          old_fs with
-          mark_open_stag = empty_string_of_styles;
-          mark_close_stag = empty_string_of_styles ~close:true;
-        }
-  | Empty, None -> ()
-  | _ -> assert false

types/misc/textStyling.mli

@@ -51,11 +51,13 @@ type marker = {
 }
 
 type stag_marker =
-  | Empty
-  | Mark of marker
-  | Print of marker
+  | Mark
+  | Print
 
-val add_stag_handlers : stag_marker -> prettify:bool -> Format.formatter -> unit
+val prettify_formatter : Format.formatter -> unit
+(** [prettify_formatter formatter] adds UTF8 prettifying to [formatter] *)
+
+val add_stag_handlers : stag_marker -> marker -> Format.formatter -> unit
 (** [add_marking ppf ~mark_open ~pp_stag ~mark_close ~pp_sep] will redefine semantic tag operations for mark opening and closing (print opening and closing are left untouched).
 
     @param ppf the formatter that will handle semantic tags