feat(Tty): custom markers

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

src/tty/Tty.ml

@@ -8,7 +8,25 @@ 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 _ mark =
+  match ansi, mark with
+  | `Disabled, `Range_begin -> "«"
+  | `Disabled, `Range_end _ -> "»"
+  | (`Enabled_with_color | `Enabled_without_color), (`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,17 +51,17 @@ 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
 
 (* 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 +79,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 +94,7 @@ struct
       severity : Diagnostic.severity;
       line_number_width : int;
       ansi : Ansi.param;
+      marker : marker;
     }
 
   (* [ ￭ examples/stlc/source.lambda] *)
@@ -83,54 +103,54 @@ 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 =
     ignore @@ List.fold_left
       (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 +165,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 +181,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 +195,7 @@ struct
       block_splitting_threshold : int;
       tab_size : int;
       ansi : Ansi.param;
+      marker : marker;
     }
 
   let line_number_width marked_source : int =
@@ -188,8 +210,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 +222,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
 
@@ -217,11 +245,12 @@ end
 module Make (Message : Minimum_signatures.Message) =
 struct
   let display ?(output=Stdlib.stdout) ?use_ansi ?use_color ?(show_backtrace=true)
-      ?(line_breaks=`Traditional) ?(block_splitting_threshold=5) ?(tab_size=8) ?(debug=false) d =
+      ?(line_breaks=`Traditional) ?(block_splitting_threshold=5)
+      ?(marker=default_marker) ?(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,9 +2,34 @@
     "The TTY handler will likely change significantly in the future to account for more features."
 ]
 
-(** {1 Display} *)
+(** {1 TTY backend} *)
 
-(** This module provides functions to display or interact with diagnostics in UNIX terminals. *)
+(** {2 Custom markers} *)
+
+(** The type of custom marker functions. A marker function takes the following three arguments:
+    + [ansi]: whether ANSI escape sequences are enabled, and if so, whether colors are used.
+    + The mark's target message: [`Main_message] is the main message, and [`Extra_remark i] is the [i]th extra remark in the diagnostic.
+    + Whether the mark indicates the start or end of a non-empty range, or the location of a point (an empty range), and whether the mark is at the end of a line or a file.
+    The output is the string to visualize the mark within the source text.
+
+    @since 0.4.0 *)
+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 visualizes point marks as ‹POS›, ‹EOL›, or ‹EOF› (depending on whether they are at the end of a line or a file) and range marks as "«" and "»" when ANSI escape sequences are disabled.
+
+    @since 0.4.0 *)
+val default_marker : marker
+
+(** {2 Display function} *)
+
+(** This module provides functions to display diagnostics in terminals. *)
 module Make (Message : Minimum_signatures.Message) : sig
 
   (** [display d] prints the diagnostic [d] to the standard output, using terminal control characters for formatting. A message will look like this (but with coloring):
@@ -22,18 +47,20 @@ module Make (Message : Minimum_signatures.Message) : sig
       v}
 
       @param output The output channel, such as {!val:stdout} or {!val:stderr}. By default, it is {!val:stdout}, the standard output.
-      @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 use_ansi Whether to use ANSI escape sequences, overriding auto-detection. ANSI escape sequences are used for coloring and styling the output. By default, auto-detection checks if the [output] is a TTY and if the environment variable [TERM] is set to a non-empty value other than [dumb].
+      @param use_color Whether to use colors when ANSI escape sequences are used, overriding auto-detection. By default, auto-detection will disable colors if ANSI escape sequences are not used or if the environment variable [NO_COLOR] is set to a non-empty value. Note that even when colors are disabled, the handler may still use bold, faint, and underline styles for highlighting if ANSI escape sequences are used. It is an error to explicitly set [use_color] to [true] and [use_ansi] to [false].
       @param show_backtrace Whether the backtrace should be shown. The default is [true].
       @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 marker A function that displays marks as strings. It takes the final values of [use_ansi] and [use_color], the target message the mark belongs to, and whether the mark indicates the start or end of a range or the location of a point. See {!type:marker} for more details. The default value is {!val:default_marker}.
       @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].
       @param debug Whether to enable the debug mode that performs expensive extra checking. The default is [false].
 
       @raise Invalid_argument if [use_color] is explicitly set to [true] but [use_ansi] is explicitly set to [false], or if [tab_size < 0], or if invalid ranges are detected. When the debug mode is enabled, detection of invalid ranges will raise the more structured exception {!exception:Source_marker.Invalid_range} instead.
       @raise Invalid_range if the debug mode is enabled and invalid ranges are detected. See {!exception:Source_marker.Invalid_range} for the detailed listing of all possible errors being reported.
 
+      @before 0.4.0 The optional parameter [marker] was not present, and angle quotation marks were not used even when ANSI escape sequences are not used.
       @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 -> ?line_breaks:[`Unicode | `Traditional] -> ?block_splitting_threshold:int -> ?marker:marker -> ?tab_size:int -> ?debug:bool -> Message.t Diagnostic.t -> unit
 end

src/tty/TtyStyle.ml → src/tty/Tty_style.ml

@@ -1,20 +1,21 @@
 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]
     | Warning -> [`Fg `Yellow]
     | 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