Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix console formatting with colors #176

Merged
merged 1 commit into from
Jan 10, 2022
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
19 changes: 9 additions & 10 deletions compiler/dcalc/print.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 ] "→ "
Expand Down
6 changes: 3 additions & 3 deletions compiler/dcalc/typing.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand Down
13 changes: 6 additions & 7 deletions compiler/lcalc/print.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand All @@ -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
Expand Down
22 changes: 11 additions & 11 deletions compiler/surface/name_resolution.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand Down Expand Up @@ -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) *)
Expand All @@ -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);
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
5 changes: 5 additions & 0 deletions compiler/utils/cli.ml
Original file line number Diff line number Diff line change
Expand Up @@ -131,6 +131,11 @@ let time : float ref = ref (Unix.gettimeofday ())
let print_with_style (styles : ANSITerminal.style list) (str : ('a, unit, string) format) =
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Can you deprecate and remove this one?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Well it's still used in many places where printing doesn't go through Format, I think it can stay

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
Expand Down
2 changes: 2 additions & 0 deletions compiler/utils/cli.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down