feat(Tty): custom markers

src/tty/Tty.ml

@@ -8,6 +8,22 @@ 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›"
+
 module SM = Source_marker.Make(TtyTag)
 
 (* calculating the width of line numbers *)
@@ -61,6 +77,7 @@ 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
@@ -75,6 +92,7 @@ struct
       severity : Diagnostic.severity;
       line_number_width : int;
       ansi : Ansi.param;
+      marker : marker;
     }
 
   (* [ ￭ examples/stlc/source.lambda] *)
@@ -83,7 +101,7 @@ struct
     | None -> ()
     | Some title -> Format.fprintf fmt " @<1>%s %s@." "￭" title
 
-  let render_line_marker ~param fmt ((_, text) as tag) =
+  let render_line_mark ~param fmt ((_, text) as tag) =
     let style = TtyStyle.message ~param:param.ansi param.severity tag in
     Format.fprintf fmt (" %*s " ^^ highlight "^" ^^ " " ^^ highlight "@[%t@]" ^^ "@.")
       param.line_number_width ""
@@ -94,35 +112,36 @@ struct
       (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 = 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)
 
   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
+      | Marked_source.Mark (sp, m) ->
+        let t, next =
+          match m with
+          | Range_end t -> t, TtyTagSet.remove t set
+          | Range_begin t -> t, TtyTagSet.add t set
+          | Point t -> t, set
+        and mark =
+          param.marker ~use_ansi:param.ansi.enabled ~use_color:param.ansi.color sp m
+        in
+        render_styled_segment ~param fmt (Some t) mark; next
     in
     Format.fprintf fmt (" " ^^ highlight "%*d |" ^^ " ")
       (Ansi.style_string ~param:param.ansi TtyStyle.fringe)
       param.line_number_width line_num
       (Ansi.reset_string ~param:param.ansi TtyStyle.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 =
@@ -161,6 +180,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 +194,7 @@ struct
       block_splitting_threshold : int;
       tab_size : int;
       ansi : Ansi.param;
+      marker : marker;
     }
 
   let line_number_width marked_source : int =
@@ -188,8 +209,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 = TtyTag.Main_message, textloc in
+      let extra_remarks = List.mapi (fun i r -> TtyTag.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 +221,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 +243,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;

src/tty/Tty.mli

@@ -2,7 +2,40 @@
     "The TTY handler will likely change significantly in the future to account for more features."
 ]
 
-(** {1 Display} *)
+(** {1 TTY backend} *)
+
+(** {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 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 +58,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 +69,5 @@ module Make (Message : Minimum_signatures.Message) : sig
 
       @see <https://no-color.org/> 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

src/tty/TtyStyle.ml

@@ -11,8 +11,8 @@ let code ~param (severity : Diagnostic.severity) : Ansi.style =
 
 let message ~param (severity : Diagnostic.severity) (tag : TtyTag.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 =
   function

src/tty/TtyTag.ml

@@ -1,13 +1,13 @@
-type index = Main | Extra of int
+type index = Main_message | Extra_remark of int
 type t = index * Text.t
 let priority =
   function
-  | Main, _ -> -1
-  | Extra i, _ -> i
+  | 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, _ -> Format.pp_print_string fmt "Main"
-  | Extra i, _ -> Format.fprintf fmt "Extra %d" i
+  | Main_message, _ -> Format.pp_print_string fmt "Main"
+  | Extra_remark i, _ -> Format.fprintf fmt "Extra %d" i