wip

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,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)
@@ -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)

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.
 

src/tty/TtyStyle.ml → 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

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