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,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,17 +49,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 +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,54 +101,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 +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;

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 <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 → 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

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

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