Fix console formatting with colors

closes #174
2024-09-19 16:28:12 +03:00 · 2022-01-10 15:00:36 +01:00 · 2022-01-10 15:00:36 +01:00 · 8d059b420e
commit 8d059b420e
parent 43c15177ad
6 changed files with 36 additions and 31 deletions
--- a/compiler/dcalc/print.ml
+++ b/compiler/dcalc/print.ml
@ -35,24 +35,23 @@ let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list
    (Format.pp_print_list
       ~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
       (fun fmt info ->
-         Format.fprintf fmt "%s"
-           (Utils.Cli.print_with_style
-              (if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else [])
-              "%s"
-              (Format.asprintf "%a" Utils.Uid.MarkedString.format_info info))))
+         Format.fprintf fmt "%a"
+           (Utils.Cli.format_with_style
+              (if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else []))
+           (Format.asprintf "%a" Utils.Uid.MarkedString.format_info info)))
    infos

 let format_keyword (fmt : Format.formatter) (s : string) : unit =
-  Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.red ] "%s" s)
+  Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.red ]) s

 let format_base_type (fmt : Format.formatter) (s : string) : unit =
-  Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" s)
+  Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) s

 let format_punctuation (fmt : Format.formatter) (s : string) : unit =
-  Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.cyan ] "%s" s)
+  Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.cyan ]) s

 let format_operator (fmt : Format.formatter) (s : string) : unit =
-  Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.green ] "%s" s)
+  Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.green ]) s

 let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
  format_base_type fmt
@ -136,7 +135,7 @@ let format_ternop (fmt : Format.formatter) (op : ternop Pos.marked) : unit =
  match Pos.unmark op with Fold -> format_keyword fmt "fold"

 let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
-  Format.fprintf fmt "%s"
+  Format.fprintf fmt "@<2>%s"
    (match entry with
    | VarDef _ -> Utils.Cli.print_with_style [ ANSITerminal.blue ] "≔ "
    | BeginCall -> Utils.Cli.print_with_style [ ANSITerminal.yellow ] "→ "
--- a/compiler/dcalc/typing.ml
+++ b/compiler/dcalc/typing.ml
@ -90,10 +90,10 @@ let rec unify (ctx : Ast.decl_ctx) (t1 : typ Pos.marked UnionFind.elem)
           (Format.asprintf "%a" (format_typ ctx) t2))
    in
    Errors.raise_multispanned_error
-      (Format.asprintf "Error during typechecking, incompatible types:\n%s %s\n%s %s"
-         (Cli.print_with_style [ ANSITerminal.blue; ANSITerminal.Bold ] "-->")
+      (Format.asprintf "Error during typechecking, incompatible types:\n%a %s\n%a %s"
+         (Cli.format_with_style [ ANSITerminal.blue; ANSITerminal.Bold ]) "-->"
         t1_s
-         (Cli.print_with_style [ ANSITerminal.blue; ANSITerminal.Bold ] "-->")
+         (Cli.format_with_style [ ANSITerminal.blue; ANSITerminal.Bold ]) "-->"
         t2_s)
      [
        (Some (Format.asprintf "Type %s coming from expression:" t1_s), t1_pos);
--- a/compiler/lcalc/print.ml
+++ b/compiler/lcalc/print.ml
@ -49,11 +49,10 @@ let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list
    (Format.pp_print_list
       ~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
       (fun fmt info ->
-         Format.fprintf fmt "%s"
-           (Utils.Cli.print_with_style
-              (if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else [])
-              "%s"
-              (Format.asprintf "%a" Utils.Uid.MarkedString.format_info info))))
+          Format.fprintf fmt "%a"
+            (Utils.Cli.format_with_style
+               (if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else []))
+            (Format.asprintf "%a" Utils.Uid.MarkedString.format_info info)))
    infos

 let format_exception (fmt : Format.formatter) (exn : except) : unit =
@ -65,10 +64,10 @@ let format_exception (fmt : Format.formatter) (exn : except) : unit =
    | NoValueProvided -> "NoValueProvided")

 let format_keyword (fmt : Format.formatter) (s : string) : unit =
-  Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.red ] "%s" s)
+  Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.red ]) s

 let format_punctuation (fmt : Format.formatter) (s : string) : unit =
-  Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.cyan ] "%s" s)
+  Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.cyan ]) s

 let needs_parens (e : expr Pos.marked) : bool =
  match Pos.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
--- a/compiler/surface/name_resolution.ml
+++ b/compiler/surface/name_resolution.ml
@ -158,8 +158,8 @@ let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
  match Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap with
  | Some use ->
      Errors.raise_multispanned_error
-        (Format.asprintf "Subscope name \"%s\" already used"
-           (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" subscope))
+        (Format.asprintf "Subscope name \"%a\" already used"
+           (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) subscope)
        [
          (Some "first use", Pos.get_position (Scopelang.Ast.SubScopeName.get_info use));
          (Some "second use", s_pos);
@ -213,8 +213,8 @@ let rec process_base_typ (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.mar
              | Some e_uid -> (Scopelang.Ast.TEnum e_uid, typ_pos)
              | None ->
                  Errors.raise_spanned_error
-                    (Format.asprintf "Unknown type \"%s\", not a struct or enum previously declared"
-                       (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" ident))
+                    (Format.asprintf "Unknown type \"%a\", not a struct or enum previously declared"
+                       (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) ident)
                    typ_pos)))

 (** Process a type (function or not) *)
@ -237,8 +237,8 @@ let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
  match Desugared.Ast.IdentMap.find_opt name scope_ctxt.var_idmap with
  | Some use ->
      Errors.raise_multispanned_error
-        (Format.asprintf "var name \"%s\" already used"
-           (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" name))
+        (Format.asprintf "var name \"%a\" already used"
+           (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) name)
        [
          (Some "first use", Pos.get_position (Scopelang.Ast.ScopeVar.get_info use));
          (Some "second use", pos);
@ -359,8 +359,8 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
 let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) : context =
  let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
    Errors.raise_multispanned_error
-      (Format.asprintf "%s name \"%s\" already defined" msg
-         (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" name))
+      (Format.asprintf "%s name \"%a\" already defined" msg
+         (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) name)
      [ (Some "First definition:", Pos.get_position use); (Some "Second definition:", pos) ]
  in
  match Pos.unmark item with
@ -584,9 +584,9 @@ let process_scope_use (ctxt : context) (suse : Ast.scope_use) : context =
    try Desugared.Ast.IdentMap.find (Pos.unmark suse.Ast.scope_use_name) ctxt.scope_idmap
    with Not_found ->
      Errors.raise_spanned_error
-        (Format.asprintf "\"%s\": this scope has not been declared anywhere, is it a typo?"
-           (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s"
-              (Pos.unmark suse.Ast.scope_use_name)))
+        (Format.asprintf "\"%a\": this scope has not been declared anywhere, is it a typo?"
+           (Utils.Cli.format_with_style [ ANSITerminal.yellow ])
+              (Pos.unmark suse.Ast.scope_use_name))
        (Pos.get_position suse.Ast.scope_use_name)
  in
  List.fold_left (process_scope_use_item s_name) ctxt suse.Ast.scope_use_items
--- a/compiler/utils/cli.ml
+++ b/compiler/utils/cli.ml
@ -131,6 +131,11 @@ let time : float ref = ref (Unix.gettimeofday ())
 let print_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 time_marker () =
  let new_time = Unix.gettimeofday () in
  let old_time = !time in
--- a/compiler/utils/cli.mli
+++ b/compiler/utils/cli.mli
@ -87,6 +87,8 @@ val info : Cmdliner.Term.info

 val print_with_style : ANSITerminal.style list -> ('a, unit, string) format -> 'a

+val format_with_style : ANSITerminal.style list -> Format.formatter -> string -> unit
+
 val debug_marker : unit -> string

 val error_marker : unit -> string