From e6ae4d897c6f4fdf8c1612648e09a719644bf13e Mon Sep 17 00:00:00 2001 From: favonia Date: Tue, 29 Oct 2024 17:33:56 -0500 Subject: [PATCH] wip --- src/tty/Tty.ml | 52 +++++++++++++-------------- src/tty/Tty.mli | 32 +++++------------ src/tty/TtyTag.ml | 13 ------- src/tty/TtyTagSet.ml | 14 -------- src/tty/{TtyStyle.ml => Tty_style.ml} | 8 ++--- src/tty/Tty_tag.ml | 12 +++++++ src/tty/Tty_tag_set.ml | 14 ++++++++ 7 files changed, 65 insertions(+), 80 deletions(-) delete mode 100644 src/tty/TtyTag.ml delete mode 100644 src/tty/TtyTagSet.ml rename src/tty/{TtyStyle.ml => Tty_style.ml} (63%) create mode 100644 src/tty/Tty_tag.ml create mode 100644 src/tty/Tty_tag_set.ml diff --git a/src/tty/Tty.ml b/src/tty/Tty.ml index a55ef82..ce7d65b 100644 --- a/src/tty/Tty.ml +++ b/src/tty/Tty.ml @@ -8,23 +8,23 @@ let string_of_severity : Diagnostic.severity -> string = | Error -> "error" | Bug -> "bug" -type index = TtyTag.index = Main_message | Extra_remark of int -type tag = TtyTag.t -type 'tag mark = 'tag Marked_source.mark = - | Range_begin of 'tag - | Range_end of 'tag - | Point of 'tag - -type marker = use_ansi:bool -> use_color:bool -> [`End_of_line | `End_of_file] option -> tag mark -> string - -let default_marker ~use_ansi:_ ~use_color:_ s m = - match s, m with - | _, (Marked_source.Range_begin _ | Range_end _) -> "" - | Some `End_of_line, Point _ -> "‹EOL›" - | Some `End_of_file, Point _ -> "‹EOF›" - | None, Point _ -> "‹POS›" +type marker = + [ `Ansi_with_color | `Ansi_without_color | `No_ansi ] + -> [ `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 : marker = fun _ _ -> + function + | `Range_begin | `Range_end _ -> "" + | `Point Some `End_of_line -> "‹EOL›" + | `Point Some `End_of_file -> "‹EOL›" + | `Point None -> "‹POS›" -module SM = Source_marker.Make(TtyTag) +module SM = Source_marker.Make(Tty_tag) (* calculating the width of line numbers *) @@ -49,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 @@ -59,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) @@ -102,18 +102,18 @@ struct | Some title -> Format.fprintf fmt " @<1>%s %s@." "￭" title let render_line_mark ~param fmt ((_, text) as tag) = - let style = TtyStyle.message ~param:param.ansi param.severity tag in + 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 = if segment <> "" then - let style = TtyStyle.highlight ~param:param.ansi param.severity tag in + 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) @@ -136,9 +136,9 @@ struct render_styled_segment ~param fmt (Some t) mark; next 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_mark ~param fmt) marks; @@ -164,7 +164,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) diff --git a/src/tty/Tty.mli b/src/tty/Tty.mli index 55487ef..39245cb 100644 --- a/src/tty/Tty.mli +++ b/src/tty/Tty.mli @@ -6,29 +6,15 @@ (** {2 Custom markers} *) -(** The index type of all messages within a diagnostic. *) -type index = - | Main_message (** The main message. *) - | Extra_remark of int (** [ExtraRemark i] is the [i]th extra remark (zero-based). *) - -(** A tag consists of an index (of type {!type:index}) and a message (of type {!type:Text.t}) *) -type tag = index * Text.t - -(** A mark signals the start or end of a non-empty range, or the location of a point (a range of zero width). *) -type 'tag mark = 'tag Marked_source.mark = - | Range_begin of 'tag - | Range_end of 'tag - | Point of 'tag - -(** The type of custom marker functions. Such a function takes four arguments: - - + [use_ansi]: whether ANSI control sequences are used. - + [use_color]: whether colors are used. (Must be false if [use_ansi] is false.) - + Whether the mark is at the end of a line or a file. - + The mark to visualize. - - The output is the string to visualize the mark within the source text. *) -type marker = use_ansi:bool -> use_color:bool -> [`End_of_line | `End_of_file] option -> tag mark -> string +(** The type of custom marker functions. The output is the string to visualize the mark within the source text. *) +type marker = + [ `Ansi_with_color | `Ansi_without_color | `No_ansi ] + -> [ `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. diff --git a/src/tty/TtyTag.ml b/src/tty/TtyTag.ml deleted file mode 100644 index 7b908cc..0000000 --- a/src/tty/TtyTag.ml +++ /dev/null @@ -1,13 +0,0 @@ -type index = Main_message | Extra_remark of int -type t = index * 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" - | Extra_remark 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 63% rename from src/tty/TtyStyle.ml rename to src/tty/Tty_style.ml index e3f4e11..4ab09af 100644 --- a/src/tty/TtyStyle.ml +++ b/src/tty/Tty_style.ml @@ -9,12 +9,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 - | Main_message, _ -> code ~param severity - | Extra_remark _, _ -> [] + | `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