From 3a0c2b9df250fdac12f3b16a1e73b20b6e101a03 Mon Sep 17 00:00:00 2001 From: favonia Date: Mon, 28 Oct 2024 08:12:37 -0500 Subject: [PATCH] feat(Tty): custom markers --- src/tty/Ansi.ml | 40 ++++++----- src/tty/Tty.ml | 96 +++++++++++++++++---------- src/tty/Tty.mli | 24 ++++++- src/tty/TtyTag.ml | 13 ---- src/tty/TtyTagSet.ml | 14 ---- src/tty/{TtyStyle.ml => Tty_style.ml} | 15 +++-- src/tty/Tty_tag.ml | 12 ++++ src/tty/Tty_tag_set.ml | 14 ++++ 8 files changed, 136 insertions(+), 92 deletions(-) delete mode 100644 src/tty/TtyTag.ml delete mode 100644 src/tty/TtyTagSet.ml rename src/tty/{TtyStyle.ml => Tty_style.ml} (52%) create mode 100644 src/tty/Tty_tag.ml create mode 100644 src/tty/Tty_tag_set.ml diff --git a/src/tty/Ansi.ml b/src/tty/Ansi.ml index c9d7bab..f0f9e29 100644 --- a/src/tty/Ansi.ml +++ b/src/tty/Ansi.ml @@ -1,7 +1,4 @@ -type param = - { enabled : bool - ; color : bool - } +type param = [ `Enabled_with_color | `Enabled_without_color | `Disabled ] type color = [ | `Black @@ -70,23 +67,21 @@ let not_color : attr -> bool = let raw_style_string st : string = String.concat "" ["\x1b["; String.concat ";" (List.map code_of_attr st); "m"] +let filter_attrs ~param st = + match param with + | `Disabled -> [] + | `Enabled_with_color -> st + | `Enabled_without_color -> List.filter not_color st + let style_string ~param st = - match param.enabled with - | false -> "" - | _ -> - let st = if param.color then st else List.filter not_color st in - match st with - | [] -> "" - | _ -> raw_style_string st + match filter_attrs ~param st with + | [] -> "" + | _ -> raw_style_string st let reset_string ~param st = - match param.enabled with - | false -> "" - | _ -> - let st = if param.color then st else List.filter not_color st in - match st with - | [] -> "" - | _ -> raw_style_string [] + match filter_attrs ~param st with + | [] -> "" + | _ -> raw_style_string [] module Test = struct @@ -106,7 +101,10 @@ struct let guess ?use_ansi ?use_color o = if use_color = Some true && use_ansi = Some false then invalid_arg "Asai.Tty.S.display: called with use_color=true but use_ansi=false"; - let enabled = match use_ansi with Some a -> a | None -> rich_term && is_tty o in - let color = enabled && match use_color with Some c -> c | None -> not no_color in - {enabled; color} + if not (match use_ansi with Some a -> a | None -> rich_term && is_tty o) then + `Disabled + else if match use_color with Some c -> c | None -> not no_color then + `Enabled_with_color + else + `Enabled_without_color end diff --git a/src/tty/Tty.ml b/src/tty/Tty.ml index c2a0a41..e4678fb 100644 --- a/src/tty/Tty.ml +++ b/src/tty/Tty.ml @@ -8,7 +8,23 @@ let string_of_severity : Diagnostic.severity -> string = | Error -> "error" | Bug -> "bug" -module SM = Source_marker.Make(TtyTag) +type marker = + ansi:[ `Enabled_with_color | `Enabled_without_color | `Disabled ] + -> [ `Main_message | `Extra_remark of int ] + -> [ `Range_begin + | `Range_end of [`End_of_line | `End_of_file] option + | `Point of [`End_of_line | `End_of_file] option + ] + -> string + +let default_marker ~ansi:_ _ = + function + | `Range_begin | `Range_end _ -> "" + | `Point Some `End_of_line -> "‹EOL›" + | `Point Some `End_of_file -> "‹EOF›" + | `Point None -> "‹POS›" + +module SM = Source_marker.Make(Tty_tag) (* calculating the width of line numbers *) @@ -33,9 +49,9 @@ let indentf ~param fmt = let num_lines = List.length lines in let p m line = Format.fprintf fmt (" " ^^ highlight "@<1>%s" ^^ "%s@.") - (Ansi.style_string ~param TtyStyle.indentation) + (Ansi.style_string ~param Tty_style.indentation) m - (Ansi.reset_string ~param TtyStyle.indentation) + (Ansi.reset_string ~param Tty_style.indentation) line in List.iteri (fun i line -> p (indent_decorations num_lines i) line) lines @@ -43,7 +59,7 @@ let indentf ~param fmt = (* different parts of the display *) let render_code ~param ~severity fmt short_code = - let style = TtyStyle.code severity ~param in + let style = Tty_style.code severity ~param in Format.fprintf fmt (" @<1>%s " ^^ highlight "%s[%s]" ^^ "@.") "￫" (Ansi.style_string ~param style) @@ -61,9 +77,10 @@ sig severity : Diagnostic.severity; line_number_width : int; ansi : Ansi.param; + marker : marker; } - val render : param:param -> Format.formatter -> TtyTag.t Marked_source.t -> unit + val render : param:param -> Format.formatter -> Tty_tag.t Marked_source.t -> unit end = struct @@ -75,6 +92,7 @@ struct severity : Diagnostic.severity; line_number_width : int; ansi : Ansi.param; + marker : marker; } (* [ ￭ examples/stlc/source.lambda] *) @@ -83,46 +101,46 @@ struct | None -> () | Some title -> Format.fprintf fmt " @<1>%s %s@." "￭" title - let render_line_marker ~param fmt ((_, text) as tag) = - let style = TtyStyle.message ~param:param.ansi param.severity tag in + let render_line_mark ~param fmt ((_, text) as tag) = + let style = Tty_style.message ~param:param.ansi param.severity tag in Format.fprintf fmt (" %*s " ^^ highlight "^" ^^ " " ^^ highlight "@[%t@]" ^^ "@.") param.line_number_width "" - (Ansi.style_string ~param:param.ansi TtyStyle.fringe) - (Ansi.reset_string ~param:param.ansi TtyStyle.fringe) + (Ansi.style_string ~param:param.ansi Tty_style.fringe) + (Ansi.reset_string ~param:param.ansi Tty_style.fringe) (Ansi.style_string ~param:param.ansi style) text (Ansi.reset_string ~param:param.ansi style) let render_styled_segment ~param fmt tag segment = - let style = TtyStyle.highlight ~param:param.ansi param.severity tag in - Format.fprintf fmt (highlight "%s") - (Ansi.style_string ~param:param.ansi style) - (String_utils.replace_control ~tab_size:param.tab_size segment) - (Ansi.reset_string ~param:param.ansi style) + if segment <> "" then + let style = Tty_style.highlight ~param:param.ansi param.severity tag in + Format.fprintf fmt (highlight "%s") + (Ansi.style_string ~param:param.ansi style) + (String_utils.replace_control ~tab_size:param.tab_size segment) + (Ansi.reset_string ~param:param.ansi style) let render_line ~line_num ~param fmt init_tag_set Marked_source.{tokens; marks} = let go set = function | Marked_source.String s -> - render_styled_segment ~param fmt (TtyTagSet.prioritized set) s; set - | Marked_source.Mark (_, Range_end t) -> - TtyTagSet.remove t set - | Marked_source.Mark (Some `End_of_file, Point t) -> - render_styled_segment ~param fmt (Some t) "‹EOF›"; set - | Marked_source.Mark (Some `End_of_line, Point t) -> - render_styled_segment ~param fmt (Some t) "‹EOL›"; set - | Marked_source.Mark (None, Point t) -> - render_styled_segment ~param fmt (Some t) "‹POS›"; set - | Marked_source.Mark (_, Range_begin t) -> - TtyTagSet.add t set + render_styled_segment ~param fmt (Tty_tag_set.prioritized set) s; set + | Marked_source.Mark (sp, m) -> + let (idx, _ as tag), m, next_set = + match m with + | Range_end t -> t, `Range_end sp, Tty_tag_set.remove t set + | Range_begin t -> t, `Range_begin, Tty_tag_set.add t set + | Point t -> t, `Point sp, set + in + let mark = param.marker ~ansi:param.ansi idx m in + render_styled_segment ~param fmt (Some tag) mark; next_set in Format.fprintf fmt (" " ^^ highlight "%*d |" ^^ " ") - (Ansi.style_string ~param:param.ansi TtyStyle.fringe) + (Ansi.style_string ~param:param.ansi Tty_style.fringe) param.line_number_width line_num - (Ansi.reset_string ~param:param.ansi TtyStyle.fringe); + (Ansi.reset_string ~param:param.ansi Tty_style.fringe); let end_tag_set = List.fold_left go init_tag_set tokens in Format.fprintf fmt "@."; - List.iter (render_line_marker ~param fmt) marks; + List.iter (render_line_mark ~param fmt) marks; end_tag_set let render_lines ~param ~begin_line_num fmt lines = @@ -130,7 +148,7 @@ struct (fun (line_num, set) line -> let set = render_line ~line_num ~param fmt set line in (line_num+1, set)) - (begin_line_num, TtyTagSet.empty) + (begin_line_num, Tty_tag_set.empty) lines let render_block ~param fmt Marked_source.{begin_line_num; end_line_num=_; lines} = @@ -145,7 +163,7 @@ struct end let render_unlocated_tag ~severity ~ansi fmt ((_, text) as tag) = - let style = TtyStyle.message ~param:ansi severity tag in + let style = Tty_style.message ~param:ansi severity tag in Format.fprintf fmt (" @<1>%s " ^^ highlight "@[%t@]" ^^ "@.") "￮" (Ansi.style_string ~param:ansi style) @@ -161,6 +179,7 @@ sig block_splitting_threshold : int; tab_size : int; ansi : Ansi.param; + marker : marker; } val render_diagnostic : param:param -> Format.formatter -> string Diagnostic.t -> unit @@ -174,6 +193,7 @@ struct block_splitting_threshold : int; tab_size : int; ansi : Ansi.param; + marker : marker; } let line_number_width marked_source : int = @@ -188,8 +208,8 @@ struct let render_textloc ~param ~severity ~extra_remarks fmt (textloc : Loctext.t) = let located_tags, unlocated_tags = - let main = TtyTag.Main, textloc in - let extra_remarks = List.mapi (fun i r -> TtyTag.Extra i, r) (Bwd.to_list extra_remarks) in + let main = `Main_message, textloc in + let extra_remarks = List.mapi (fun i r -> `Extra_remark i, r) (Bwd.to_list extra_remarks) in List.partition_map (function | (tag, Range.{loc = None; value = text}) -> Either.Right (tag, text) @@ -200,7 +220,13 @@ struct SM.mark ~block_splitting_threshold:param.block_splitting_threshold ~debug:param.debug located_tags in let line_number_width = line_number_width marked_source in - let param = {Marked_source_renderer.severity = severity; tab_size = param.tab_size; line_number_width; ansi = param.ansi} in + let param = { + Marked_source_renderer.severity = severity; + tab_size = param.tab_size; + line_number_width; + ansi = param.ansi; + marker = param.marker + } in Marked_source_renderer.render ~param fmt marked_source; List.iter (render_unlocated_tag ~severity:param.severity ~ansi:param.ansi fmt) unlocated_tags @@ -216,12 +242,12 @@ end module Make (Message : Minimum_signatures.Message) = struct - let display ?(output=Stdlib.stdout) ?use_ansi ?use_color ?(show_backtrace=true) + let display ?(output=Stdlib.stdout) ?use_ansi ?use_color ?(show_backtrace=true) ?(marker=default_marker) ?(line_breaks=`Traditional) ?(block_splitting_threshold=5) ?(tab_size=8) ?(debug=false) d = let d = if show_backtrace then d else {d with Diagnostic.backtrace = Emp} in let d = Diagnostic.map Message.short_code d in let ansi = Ansi.Test.guess ?use_ansi ?use_color output in - let param = {Diagnostic_renderer.debug; line_breaks; block_splitting_threshold; tab_size; ansi} in + let param = {Diagnostic_renderer.debug; line_breaks; block_splitting_threshold; tab_size; ansi; marker} in let fmt = Format.formatter_of_out_channel output in Source_reader.run @@ fun () -> Diagnostic_renderer.render_diagnostic ~param fmt d; diff --git a/src/tty/Tty.mli b/src/tty/Tty.mli index 963795b..f3bac87 100644 --- a/src/tty/Tty.mli +++ b/src/tty/Tty.mli @@ -2,7 +2,26 @@ "The TTY handler will likely change significantly in the future to account for more features." ] -(** {1 Display} *) +(** {1 TTY backend} *) + +(** {2 Custom markers} *) + +(** The type of custom marker functions. The output is the string to visualize the mark within the source text. *) +type marker = + ansi:[ `Enabled_with_color | `Enabled_without_color | `Disabled ] + -> [ `Main_message | `Extra_remark of int ] + -> [ `Range_begin + | `Range_end of [`End_of_line | `End_of_file] option + | `Point of [`End_of_line | `End_of_file] option + ] + -> string + +(** The default marker. Currently, it transforms point marks into [‹POS›], [‹EOL›], or [‹EOF›] (depending on whether they are at the end of a line or a file) and ignores all range marks. This function is subject to change; future versions may display range marks when [use_ansi] is false. + + @since 0.4.0 *) +val default_marker : marker + +(** {2 Display function} *) (** This module provides functions to display or interact with diagnostics in UNIX terminals. *) module Make (Message : Minimum_signatures.Message) : sig @@ -25,6 +44,7 @@ module Make (Message : Minimum_signatures.Message) : sig @param use_ansi Whether ANSI escape sequences should be used, overwriting the auto-detection. By default, the auto-detection checks whether the [output] is a TTY and whether the environment variable [TERM] is set to a non-empty value other than [dumb]. Note that this handler is currently using {i exclusively} ANSI escape sequences for highlighting, which means turning them off will lose the precise location. (This may change in the future.) @param use_color Whether colors should be use when ANSI escape sequences are used, overwriting the auto-detection. By default, the auto-detection will turn off the colors if ANSI escape sequences should not be used or if a non-empty value was assigned to the environment variable [NO_COLOR]. Note that even when the colors are turned off, the handler may still use the bold style, the faint style, and underlines for highlighting if ANSI escape sequences are used. It is an error to pass [true] as this parameter and [false] as [use_ansi]. @param show_backtrace Whether the backtrace should be shown. The default is [true]. + @param marker A function that that displays markers as strings. It takes the final values of [use_ansi] and [use_color], an indication whether it is at the end of a line or a file, and the marker to visualize. See {!type:marker}. The default value is {!val:default_marker}. @param line_breaks The set of character sequences that are recognized as (hard) line breaks. The [`Unicode] set contains all Unicode character sequences in {{:https://www.unicode.org/versions/Unicode15.0.0/ch05.pdf#G41643}Unicode 15.0.0 Table 5-1.} The [`Traditional] set only contains [U+000A (LF)], [U+000D (CR)], and [U+000D U+000A (CRLF)] as line breaks. The default is the [`Traditional] set. @param block_splitting_threshold The maximum number of consecutive, non-highlighted lines allowed in a block. The function will try to minimize the number of blocks, as long as no block has too many consecutive, non-highlighted lines. A higher threshold will lead to fewer blocks. When the threshold is zero, it means no block can contain any non-highlighted line. The default value is [5]. @param tab_size The number of spaces that should be used to replace a horizontal tab. Note that a horizontal tab is always expanded to the same number of spaces. The result should still be visually appealing as long as horizontal tabs are only used at the beginning of lines. The default value is [8]. @@ -35,5 +55,5 @@ module Make (Message : Minimum_signatures.Message) : sig @see for the [NO_COLOR] specification *) - val display : ?output:out_channel -> ?use_ansi:bool -> ?use_color:bool -> ?show_backtrace:bool -> ?line_breaks:[`Unicode | `Traditional] -> ?block_splitting_threshold:int -> ?tab_size:int -> ?debug:bool -> Message.t Diagnostic.t -> unit + val display : ?output:out_channel -> ?use_ansi:bool -> ?use_color:bool -> ?show_backtrace:bool -> ?marker:marker -> ?line_breaks:[`Unicode | `Traditional] -> ?block_splitting_threshold:int -> ?tab_size:int -> ?debug:bool -> Message.t Diagnostic.t -> unit end diff --git a/src/tty/TtyTag.ml b/src/tty/TtyTag.ml deleted file mode 100644 index f0928c5..0000000 --- a/src/tty/TtyTag.ml +++ /dev/null @@ -1,13 +0,0 @@ -type index = Main | Extra of int -type t = index * Text.t -let priority = - function - | Main, _ -> -1 - | Extra i, _ -> i -let compare t1 t2 = - Utils.compare_pair Int.compare Stdlib.compare - (priority t1, t1) (priority t2, t2) -let dump fmt = - function - | Main, _ -> Format.pp_print_string fmt "Main" - | Extra i, _ -> Format.fprintf fmt "Extra %d" i diff --git a/src/tty/TtyTagSet.ml b/src/tty/TtyTagSet.ml deleted file mode 100644 index a0d3bb3..0000000 --- a/src/tty/TtyTagSet.ml +++ /dev/null @@ -1,14 +0,0 @@ -module TagMap = Map.Make(TtyTag) -type t = int TagMap.t -let empty : t = TagMap.empty -let is_empty : t -> bool = TagMap.is_empty -let add t = - TagMap.update t @@ function - | None -> Some 1 - | Some n -> Some (n+1) -let remove t = - TagMap.update t @@ function - | None -> failwith "Asai.Tty.S.display: removing a non-existing tag from a tag set" - | Some 1 -> None - | Some n -> Some (n-1) -let prioritized s = Option.map fst @@ TagMap.min_binding_opt s diff --git a/src/tty/TtyStyle.ml b/src/tty/Tty_style.ml similarity index 52% rename from src/tty/TtyStyle.ml rename to src/tty/Tty_style.ml index da8fafd..50088c8 100644 --- a/src/tty/TtyStyle.ml +++ b/src/tty/Tty_style.ml @@ -1,7 +1,8 @@ let code ~param (severity : Diagnostic.severity) : Ansi.style = - if not param.Ansi.color then - [`Bold] - else + match param with + | `Disabled -> [] + | `Enabled_without_color -> [`Bold] + | `Enabled_with_color -> match severity with | Hint -> [`Fg `Blue] | Info -> [`Fg `Green] @@ -9,12 +10,12 @@ let code ~param (severity : Diagnostic.severity) : Ansi.style = | Error -> [`Fg `Red] | Bug -> [`Bg `Red; `Fg `Black] -let message ~param (severity : Diagnostic.severity) (tag : TtyTag.t) : Ansi.style = +let message ~param (severity : Diagnostic.severity) (tag : Tty_tag.t) : Ansi.style = match tag with - | Extra _, _ -> [] - | Main, _ -> code ~param severity + | `Main_message, _ -> code ~param severity + | `Extra_remark _, _ -> [] -let highlight ~param (severity : Diagnostic.severity) : TtyTag.t option -> Ansi.style = +let highlight ~param (severity : Diagnostic.severity) : Tty_tag.t option -> Ansi.style = function | None -> [] | Some tag -> [`Underline] @ message ~param severity tag diff --git a/src/tty/Tty_tag.ml b/src/tty/Tty_tag.ml new file mode 100644 index 0000000..3e45d34 --- /dev/null +++ b/src/tty/Tty_tag.ml @@ -0,0 +1,12 @@ +type t = [ `Main_message | `Extra_remark of int ] * Text.t +let priority = + function + | `Main_message, _ -> -1 + | `Extra_remark i, _ -> i +let compare t1 t2 = + Utils.compare_pair Int.compare Stdlib.compare + (priority t1, t1) (priority t2, t2) +let dump fmt = + function + | `Main_message, _ -> Format.pp_print_string fmt "`Main_message" + | `Extra_remark i, _ -> Format.fprintf fmt "`Extra_remark %d" i diff --git a/src/tty/Tty_tag_set.ml b/src/tty/Tty_tag_set.ml new file mode 100644 index 0000000..b8139b7 --- /dev/null +++ b/src/tty/Tty_tag_set.ml @@ -0,0 +1,14 @@ +module Tag_map = Map.Make(Tty_tag) +type t = int Tag_map.t +let empty : t = Tag_map.empty +let is_empty : t -> bool = Tag_map.is_empty +let add t = + Tag_map.update t @@ function + | None -> Some 1 + | Some n -> Some (n+1) +let remove t = + Tag_map.update t @@ function + | None -> failwith "Asai.Tty.S.display: removing a non-existing tag from a tag set" + | Some 1 -> None + | Some n -> Some (n-1) +let prioritized s = Option.map fst @@ Tag_map.min_binding_opt s