diff --git a/src-lsp/LspShims.ml b/src-lsp/LspShims.ml index e79cb07..24f49e0 100644 --- a/src-lsp/LspShims.ml +++ b/src-lsp/LspShims.ml @@ -10,11 +10,7 @@ struct let lsp_range_of_range (r : Asai.Range.t option) = match r with | Some r -> - let (start , stop) = - match Asai.Range.view r with - | `Range (start, stop) -> start, stop - | `End_of_file pos -> pos, pos - in + let (start, stop) = Asai.Range.split r in L.Range.create ~start:(lsp_pos_of_pos start) ~end_:(lsp_pos_of_pos stop) diff --git a/src/Explication.ml b/src/Explication.ml index f2c4ded..f3add5b 100644 --- a/src/Explication.ml +++ b/src/Explication.ml @@ -1,11 +1,20 @@ include ExplicationData -let dump_seg dump_tag = Utils.dump_pair (Utils.dump_option dump_tag) Utils.dump_string +let dump_marker dump_tag fmt = + function + | RangeBegin tag -> Format.fprintf fmt {|@[<2>RangeBegin@ @[%a@]@]|} dump_tag tag + | RangeEnd tag -> Format.fprintf fmt {|@[<2>RangeEnd@ @[%a@]@]|} dump_tag tag + | Point tag -> Format.fprintf fmt {|@[<2>Point@ @[%a@]@]|} dump_tag tag -let dump_line dump_tag fmt {tags; segments} = - Format.fprintf fmt {|@[<1>{@[<2>tags=@,@[%a@]@];@ @[<2>segments=@ @[%a@]@]}@]|} - (Utils.dump_list dump_tag) tags - (Utils.dump_list (dump_seg dump_tag)) segments +let dump_token dump_tag fmt = + function + | String str -> Format.fprintf fmt {|@[<2>String@ "%s"@]|} (String.escaped str) + | Marker m -> Format.fprintf fmt {|@[<2>Marker@ @[<1>(%a)@]@]|} (dump_marker dump_tag) m + +let dump_line dump_tag fmt {markers; tokens} = + Format.fprintf fmt {|@[<1>{@[<2>markers=@,@[%a@]@];@ @[<2>tokens=@ @[%a@]@]}@]|} + (Utils.dump_list dump_tag) markers + (Utils.dump_list (dump_token dump_tag)) tokens let dump_block dump_tag fmt {begin_line_num; end_line_num; lines} = Format.fprintf fmt {|@[<1>{begin_line_num=%d;@ end_line_num=%d;@ @[<2>lines=@ @[%a@]@]}@]|} diff --git a/src/Explication.mli b/src/Explication.mli index 9956454..0b2193e 100644 --- a/src/Explication.mli +++ b/src/Explication.mli @@ -5,5 +5,8 @@ include module type of ExplicationData (** {1 Debugging} *) -(** Ugly printer for debugging *) +(** Ugly printer for {!type:marker} *) +val dump_marker : (Format.formatter -> 'tag -> unit) -> Format.formatter -> 'tag marker -> unit + +(** Ugly printer for {!type:t} *) val dump : (Format.formatter -> 'tag -> unit) -> Format.formatter -> 'tag t -> unit diff --git a/src/ExplicationData.ml b/src/ExplicationData.ml index 29947cc..98f47e6 100644 --- a/src/ExplicationData.ml +++ b/src/ExplicationData.ml @@ -1,10 +1,18 @@ -(** A segment is an optionally tagged string from the user content. (Note the use of [option].) *) -type 'tag segment = 'tag option * string +(** A marker is a delimiter of a range or a specific point. *) +type 'tag marker = + | RangeBegin of 'tag + | RangeEnd of 'tag + | Point of 'tag + +(** A token is either a string or a marker. *) +type 'tag token = + | String of string + | Marker of 'tag marker (** A line is a list of {!type:segment}s along with tags. *) type 'tag line = - { tags : 'tag list - ; segments : 'tag segment list + { markers : 'tag list (** All tags in this line *) + ; tokens : 'tag token list } (** A block is a collection of consecutive lines. *) diff --git a/src/Explicator.ml b/src/Explicator.ml index 9bba26d..dc4249c 100644 --- a/src/Explicator.ml +++ b/src/Explicator.ml @@ -30,9 +30,6 @@ let print_invalid_range fmt : UserContent.invalid_range -> unit = Format.fprintf fmt "its@ beginning@ position@ is@ invalid;@ %a" print_invalid_position r | `End r -> Format.fprintf fmt "its@ ending@ position@ is@ invalid;@ %a" print_invalid_position r - | `Not_end_of_file (l, l') -> - Format.fprintf fmt "its@ offset@ %d@ is@ not@ the@ end@ of@ file@ (%d)." l l' - | `End_of_file r -> print_invalid_position fmt r let () = Printexc.register_printer @@ function @@ -45,12 +42,11 @@ let () = Printexc.register_printer @@ | _ -> None let to_start_of_line (pos : Range.position) = {pos with offset = pos.start_of_line} -let default_blend ~(priority : _ -> int) t1 t2 = if priority t2 <= priority t1 then t2 else t1 module Make (Tag : Tag) = struct type position = Range.position - (** Skip the newline sequence, assuming that [shift] is not zero. (Otherwise, it means we already reached eof.) *) + (** Skip the newline sequence, assuming that [shift] is not zero. (Otherwise, it means we already reached EOF.) *) let eol_to_next_line shift (pos : position) : position = assert (shift <> 0); { source = pos.source; @@ -65,9 +61,8 @@ module Make (Tag : Tag) = struct type explicator_state = { lines : Tag.t line bwd - ; segments : Tag.t segment bwd - ; remaining_tagged_lines : (Tag.t * int) list - ; current_tag : Tag.t option + ; tokens : Tag.t token bwd + ; remaining_line_markers : (int * Tag.t) list ; cursor : Range.position ; eol : int ; eol_shift : int option @@ -76,96 +71,95 @@ module Make (Tag : Tag) = struct module F = Flattener.Make(Tag) - let explicate_block ~line_breaks (b : Tag.t Flattener.block) : Tag.t block = - match b.tagged_positions with - | [] -> invalid_arg "explicate_block: empty block" - | ((_, ploc) :: _) as ps -> - let source = SourceReader.load ploc.source in + let explicate_block ~line_breaks source (b : Tag.t Flattener.block) : Tag.t block = + match b.markers with + | [] -> invalid_arg "explicate_block: empty block; should be impossible" + | ((first_loc, _) :: _) as markers -> + let source = SourceReader.load source in let eof = SourceReader.length source in let find_eol i = UserContent.find_eol ~line_breaks (SourceReader.unsafe_get source) (i, eof) in - let rec go state : (Tag.t option * Range.position) list -> _ = + let rec go state : (Range.position * Tag.t marker) list -> _ = function - | (ptag, ploc) :: ps when state.cursor.line_num = ploc.line_num -> - if ploc.offset > eof then invalid_arg "Asai.Explicator.explicate: beyond eof; use the debug mode"; - if ploc.offset > state.eol then invalid_arg "Asai.Explicator.explicate: unexpected newline; use the debug mode"; - if ploc.offset = state.cursor.offset then - go {state with cursor = ploc; current_tag = ptag} ps - else - (* Still on the same line *) - let segments = - state.segments <: - (state.current_tag, read_between ~source state.cursor.offset ploc.offset) - in - go { state with segments; cursor = ploc; current_tag = ptag } ps - | ps -> + | (loc, marker) :: markers when state.cursor.line_num = loc.line_num (* on the same line *) -> + if loc.offset > eof then invalid_arg "Asai.Explicator.explicate: position beyond EOF; use the debug mode"; + if loc.offset > state.eol then invalid_arg "Asai.Explicator.explicate: unexpected newline; use the debug mode"; + let tokens = + if loc.offset = state.cursor.offset then + state.tokens <: Marker marker + else + state.tokens <: String (read_between ~source state.cursor.offset loc.offset) <: Marker marker + in + go { state with tokens; cursor = loc } markers + | markers -> (* Shifting to the next line *) - let lines, remaining_tagged_lines = - let segments = + let lines, remaining_line_markers = + let tokens = if state.cursor.offset < state.eol then - state.segments - <: (state.current_tag, read_between ~source state.cursor.offset state.eol) - else if Option.is_none state.eol_shift && Option.is_some state.current_tag then - state.segments - <: (state.current_tag, "‹EOF›") + state.tokens <: String (read_between ~source state.cursor.offset state.eol) else - state.segments + state.tokens + in + let line_markers, remaining_line_markers = + Utils.span (fun (line_num, _) -> line_num = state.line_num) state.remaining_line_markers in - let tagged_lines, remaining_tagged_lines = Utils.span (fun (_, i) -> i = state.line_num) state.remaining_tagged_lines in - (state.lines <: {segments = Bwd.to_list segments; tags = List.map fst tagged_lines}), remaining_tagged_lines + (state.lines <: + { tokens = Bwd.to_list tokens + ; markers = List.map snd line_markers + }), + remaining_line_markers in - (* Continue the process if [ps] is not empty. *) - match ps, state.eol_shift with + (* Continue the process if [markers] is not empty. *) + match markers, state.eol_shift with | [], _ -> assert (state.line_num = b.end_line_num); lines - | _ :: _, None -> invalid_arg "Asai.Explicator.explicate: beyond eof; use the debug mode" - | (_, ploc) :: _, Some eol_shift -> - if ploc.offset > eof then invalid_arg "Asai.Explicator.explicate: beyond eof; use the debug mode"; - if ploc.offset <= state.eol then invalid_arg "Asai.Explicator.explicate: expected newline missing; use the debug mode"; - if ploc.offset < state.eol + eol_shift then invalid_arg "Asai.Explicator.explicate: offset within newline; use the debug mode"; + | _ :: _, None -> invalid_arg "Asai.Explicator.explicate: position beyond EOF; use the debug mode" + | (loc, _) :: _, Some eol_shift -> + if loc.offset > eof then invalid_arg "Asai.Explicator.explicate: position beyond EOF; use the debug mode"; + if loc.offset <= state.eol then invalid_arg "Asai.Explicator.explicate: expected newline missing; use the debug mode"; + if loc.offset < state.eol + eol_shift then invalid_arg "Asai.Explicator.explicate: offset within newline; use the debug mode"; (* Okay, p is really on the next line *) let cursor = eol_to_next_line eol_shift {state.cursor with offset = state.eol} in let eol, eol_shift = find_eol (state.eol + eol_shift) in go { lines - ; segments = Emp - ; remaining_tagged_lines - ; current_tag = state.current_tag + ; tokens = Emp + ; remaining_line_markers ; cursor ; eol ; eol_shift ; line_num = state.line_num + 1 } - ps + markers in - let begin_pos = to_start_of_line ploc in - let eol, eol_shift = find_eol ploc.offset in let lines = + let begin_pos = to_start_of_line first_loc in + let eol, eol_shift = find_eol first_loc.offset in go { lines = Emp - ; segments = Emp - ; remaining_tagged_lines = b.tagged_lines - ; current_tag = None + ; tokens = Emp + ; remaining_line_markers = b.line_markers ; cursor = begin_pos ; eol ; eol_shift ; line_num = b.begin_line_num } - ps + markers in { begin_line_num = b.begin_line_num ; end_line_num = b.end_line_num ; lines = Bwd.to_list @@ lines } - let[@inline] explicate_blocks ~line_breaks = List.map (explicate_block ~line_breaks) + let[@inline] explicate_blocks ~line_breaks source ranges = + List.map (explicate_block ~line_breaks source) ranges let[@inline] explicate_part ~line_breaks (source, bs) : Tag.t part = - { source; blocks = explicate_blocks ~line_breaks bs } + { source; blocks = explicate_blocks ~line_breaks source bs } let check_ranges ~line_breaks ranges = List.iter - (fun (_, range) -> + (fun (range, _) -> let source = SourceReader.load @@ Range.source range in let read = SourceReader.unsafe_get source in let eof = SourceReader.length source in @@ -173,8 +167,7 @@ module Make (Tag : Tag) = struct with UserContent.Invalid_range reason -> raise @@ Invalid_range (range, reason)) ranges - let explicate ?(line_breaks=`Traditional) ?(block_splitting_threshold=5) - ?(blend=default_blend ~priority:Tag.priority) ?(debug=false) ranges = + let explicate ?(line_breaks=`Traditional) ?(block_splitting_threshold=5) ?(debug=false) ranges = if debug then check_ranges ~line_breaks ranges; - List.map (explicate_part ~line_breaks) @@ F.flatten ~block_splitting_threshold ~blend ranges + List.map (explicate_part ~line_breaks) @@ F.flatten ~block_splitting_threshold ranges end diff --git a/src/Explicator.mli b/src/Explicator.mli index 68c44a8..aa101eb 100644 --- a/src/Explicator.mli +++ b/src/Explicator.mli @@ -1,7 +1,4 @@ include module type of ExplicatorSigs -(** The default tag blending algorithm that chooses the more important tag based on priority. *) -val default_blend : priority:('tag -> int) -> 'tag -> 'tag -> 'tag - (** Making an explicator. *) module Make : functor (Tag : Tag) -> S with module Tag := Tag diff --git a/src/ExplicatorSigs.ml b/src/ExplicatorSigs.ml index 4f0fd22..f005b43 100644 --- a/src/ExplicatorSigs.ml +++ b/src/ExplicatorSigs.ml @@ -8,7 +8,9 @@ module type Tag = sig (** The abstract type of tags. *) type t - (** Get the priority number of a tag. We followed the UNIX convention here---a {i smaller} priority number represents higher priority. The convention works well with {!val:List.sort}, which sorts numbers in ascending order. (The more important things go first.) *) + (** Get the priority number of a tag. A {i smaller} priority number represents higher priority. + + The convention works well with {!val:List.sort}, which sorts numbers in ascending order: the more important things go first. *) val priority : t -> int (** Ugly printer for debugging *) @@ -19,12 +21,11 @@ end module type S = sig module Tag : Tag - val explicate : ?line_breaks:[`Unicode | `Traditional] -> ?block_splitting_threshold:int -> ?blend:(Tag.t -> Tag.t -> Tag.t) -> ?debug:bool -> (Tag.t * Range.t) list -> Tag.t t + val explicate : ?line_breaks:[`Unicode | `Traditional] -> ?block_splitting_threshold:int -> ?debug:bool -> (Range.t * Tag.t) list -> Tag.t t (** Explicate a list of ranges using content from a data reader. This function must be run under [SourceReader.run]. @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 zero. - @param blend The algorithm to blend two tags on a visual range. The default algorithm chooses the more important tag based on priority. @param debug Whether to enable the debug mode that performs expensive extra checking. The default is [false]. @raise Invalid_range See {!exception:Invalid_range}. diff --git a/src/Flattener.ml b/src/Flattener.ml index 9d17038..2a9279b 100644 --- a/src/Flattener.ml +++ b/src/Flattener.ml @@ -1,28 +1,30 @@ open Bwd open Bwd.Infix +open Explication open ExplicatorSigs type 'tag block = { begin_line_num : int ; end_line_num : int - ; tagged_positions : ('tag option * Range.position) list - ; tagged_lines : ('tag * int) list} + ; markers : (Range.position * 'tag marker) list + ; line_markers : (int * 'tag) list} type 'tag t = (Range.source * 'tag block list) list -let dump_block dump_tag fmt {begin_line_num; end_line_num; tagged_positions; tagged_lines} : unit = +let dump_block dump_tag fmt {begin_line_num; end_line_num; markers; line_markers} : unit = Format.fprintf fmt begin "@[<1>{" ^^ "begin_line_num=%d;@ " ^^ "end_line_num=%d;@ " ^^ - "@[<2>tagged_positions=@ @[%a@]@];@ " ^^ - "@[<2>tagged_lines=@,@[%a@]@]}@]" + "@[<2>markers=@ @[%a@]@];@ " ^^ + "@[<2>marked_lines=@,@[%a@]@]" ^^ + "}@]" end begin_line_num end_line_num - (Utils.dump_list (Utils.dump_pair (Utils.dump_option dump_tag) Range.dump_position)) tagged_positions - (Utils.dump_list (Utils.dump_pair dump_tag Format.pp_print_int)) tagged_lines + (Utils.dump_list (Utils.dump_pair Range.dump_position (dump_marker dump_tag))) markers + (Utils.dump_list (Utils.dump_pair Format.pp_print_int dump_tag)) line_markers let dump dump_tag = Utils.dump_list @@ Utils.dump_pair Range.dump_source (Utils.dump_list (dump_block dump_tag)) @@ -32,152 +34,166 @@ struct type unflattened_block = { begin_line_num : int ; end_line_num : int - ; ranges : (Tag.t * Range.t) list} + ; ranges : (Range.t * Tag.t) list + } - module Splitter : + let compare_position (p1 : Range.position) (p2 : Range.position) = + Int.compare p1.offset p2.offset + + (* Stage 1: group ranges into blocks *) + module RangePartitioner : sig - val partition : block_splitting_threshold:int -> (Tag.t * Range.t) list -> unflattened_block list + val partition : block_splitting_threshold:int -> (Range.t * Tag.t) list -> unflattened_block list end = struct - let compare_range (s1 : Range.t) (s2 : Range.t) = - Utils.compare_pair Int.compare Int.compare - (Range.end_offset s1, Range.begin_offset s1) - (Range.end_offset s2, Range.begin_offset s2) - - let compare_range_tagged (t1, sp1) (t2, sp2) = - Utils.compare_pair compare_range Int.compare - (sp1, Tag.priority t1) - (sp2, Tag.priority t2) - - let sort_tagged = List.stable_sort compare_range_tagged + (* Sort the ranges by their ending positions; + if equal sort them by their beginning positions in reverse (larger ranges go last); + if still equal, sort them by priority (important ones go first) *) + let sort_tagged = + let compare_range (s1 : Range.t) (s2 : Range.t) = + let b1, e1 = Range.split s1 + and b2, e2 = Range.split s2 + in + Utils.compare_pair compare_position (Utils.compare_opposite compare_position) + (e1, b1) (e2, b2) + in + let compare_range_tagged (sp1, t1) (sp2, t2) = + Utils.compare_pair compare_range Int.compare + (sp1, Tag.priority t1) (sp2, Tag.priority t2) + in + List.stable_sort compare_range_tagged - let block_of_range ((_, sloc) as s) : unflattened_block = - { begin_line_num = Range.begin_line_num sloc - ; end_line_num = Range.end_line_num sloc - ; ranges = [s]} + let singleton ((range, _) as r) : unflattened_block = + { begin_line_num = Range.begin_line_num range + ; end_line_num = Range.end_line_num range + ; ranges = [ r ] + } let partition_sorted ~block_splitting_threshold l : unflattened_block list = let rec go rs block (blocks : unflattened_block list) = match rs with | Emp -> block :: blocks - | Snoc (rs, ((_, rloc) as r)) -> - if block.begin_line_num - Range.end_line_num rloc > block_splitting_threshold then - go rs (block_of_range r) (block :: blocks) + | Snoc (rs, ((range, _) as r)) -> + if block.begin_line_num - Range.end_line_num range > block_splitting_threshold then + go rs (singleton r) (block :: blocks) else - let begin_line_num = Int.min block.begin_line_num (Range.begin_line_num rloc) in + let begin_line_num = Int.min block.begin_line_num (Range.begin_line_num range) in go rs {block with begin_line_num; ranges = r :: block.ranges} blocks in - match Bwd.of_list l with + match l with | Emp -> [] | Snoc (rs, r) -> - go rs (block_of_range r) [] + go rs (singleton r) [] let partition ~block_splitting_threshold l = - partition_sorted ~block_splitting_threshold (sort_tagged l) + partition_sorted ~block_splitting_threshold @@ Bwd.of_list @@ sort_tagged l end + (* Stage 2: for each block, flatten out ranges into markers + + The code needs to handle several subtleties, using the XML-like notation to demonstrate: + 1. The ordering of markers and text strings should be ordered like this: + ...... + Note that, in the middle, RangeEnd goes first, and then Point, and then RangeBegin. + 2. If the set of ranges is "well-scoped" (that is, a range is always completely included in, + completely including, or being disjoint from another range), then matching beginning and + ending markers will have the expected nested structures, like this: + ...... + 3. For two ranges marking the same text with different priorities, the prioritized one goes inside. + For two ranges with the same text and priority, the order of beginning markers will follow + the order of the original input list. This is to reduce interruption of the prioritized highlighting. + ... + *) module BlockFlattener : sig - val flatten : blend:(Tag.t -> Tag.t -> Tag.t) -> (Tag.t * Range.t) list -> (Tag.t option * Range.position) list + val flatten : (Range.t * Tag.t) list -> (Range.position * Tag.t marker) list end = struct - type t = (Tag.t option * Range.position) bwd + type t = + { begins : (Range.position * Tag.t marker) bwd + ; points : (Range.position * Tag.t marker) bwd + ; ends : (Range.position * Tag.t marker) list + } - (* precondition: x1 < x2 and there are already points at x1 and x2 *) - let impose ~blend xtag (x1 : int) (x2 : int) : t -> t = - let blend_opt = - function - | None -> Some xtag - | Some t -> Some (blend t xtag) - in - let[@tail_mod_cons] rec go2 : t -> t = - function - | Snoc (ps, (ptag, ploc)) when ploc.offset >= x1 -> - Snoc (go2 ps, (blend_opt ptag, ploc)) - | ps -> ps - in - let[@tail_mod_cons] rec go1 : t -> t = - function - | Snoc (ps, ((_, ploc) as p)) when ploc.offset >= x2 -> - Snoc (go1 ps, p) - | ps -> go2 ps - in - go1 + let add (range, tag) {begins; points; ends} = + let b, e = Range.split range in + if b.offset = e.offset then + {begins; points = points <: (b, Point tag); ends} + else + {begins = begins <: (b, RangeBegin tag); points; ends = (e, RangeEnd tag) :: ends} - let ensure_point (x : Range.position) = - let[@tail_mod_cons] rec go : t -> t = + let sort_marker = + let marker_order = function - | Snoc (ps, ((_, ploc) as p)) when ploc.offset > x.offset -> - Snoc (go ps, p) - | Emp -> Emp <: (None, x) - | Snoc (_, (ptag, p)) as ps -> - if p.offset = x.offset then - ps - else - ps <: (ptag, x) + | RangeEnd _ -> -1 + | Point _ -> 0 + | RangeBegin _ -> 1 in - go + let compare_marker m1 m2 = Int.compare (marker_order m1) (marker_order m2) in + List.stable_sort (Utils.compare_pair compare_position compare_marker) - let add ~blend l (tag, value) = - match Range.view value with - | `Range (x1, x2) -> - impose ~blend tag x1.offset x2.offset @@ ensure_point x2 @@ ensure_point x1 l - | `End_of_file x -> - impose ~blend tag x.offset Int.max_int @@ ensure_point x l + let merge_marker {begins; points; ends} = + begins @> points @> ends - let flatten ~blend l = - Bwd.to_list @@ List.fold_left (add ~blend) Emp l + let flatten l = + sort_marker @@ merge_marker @@ + Bwd.fold_right add (Bwd.of_list l) {begins = Emp; points = Emp; ends = []} end - module File : + module FileFlattener : sig - val flatten : block_splitting_threshold:int -> blend:(Tag.t -> Tag.t -> Tag.t) -> (Tag.t * Range.t) list -> Tag.t block list + val flatten : block_splitting_threshold:int -> (Range.t * Tag.t) list -> Tag.t block list end = struct - let flatten_block ~blend ({begin_line_num; end_line_num; ranges} : unflattened_block) = - { begin_line_num - ; end_line_num - ; tagged_positions = BlockFlattener.flatten ~blend ranges - ; tagged_lines = List.map (fun (tag, value) -> tag, Range.end_line_num value) ranges - } + let flatten_block ({begin_line_num; end_line_num; ranges} : unflattened_block) = + let markers = BlockFlattener.flatten ranges in + let line_markers = + List.filter_map + (function + | (_, RangeBegin _) -> None + | (p, RangeEnd tag) | (p, Point tag) -> Some (p.Range.line_num, tag)) + markers + in + { begin_line_num; end_line_num; markers; line_markers } - let flatten ~block_splitting_threshold ~blend rs = - List.map (flatten_block ~blend) @@ Splitter.partition ~block_splitting_threshold rs + let flatten ~block_splitting_threshold rs = + List.map flatten_block @@ RangePartitioner.partition ~block_splitting_threshold rs end module Files : sig - val flatten : block_splitting_threshold:int -> blend:(Tag.t -> Tag.t -> Tag.t) -> (Tag.t * Range.t) list -> (Range.source * Tag.t block list) list + val flatten : block_splitting_threshold:int -> (Range.t * Tag.t) list -> (Range.source * Tag.t block list) list end = struct module FileMap = Map.Make(struct type t = Range.source - let compare : t -> t -> int = Stdlib.compare + let compare = Stdlib.compare end) - let add m data = + let add m ((range, _) as data) = m |> - FileMap.update (Range.source (snd data)) @@ function + FileMap.update (Range.source range) @@ function | None -> Some (Emp <: data) | Some rs -> Some (rs <: data) - let priority l : int = List.fold_left (fun p (tag, _) -> Int.min p (Tag.priority tag)) Int.max_int l + let priority l : int = List.fold_left (fun p (_, tag) -> Int.min p (Tag.priority tag)) Int.max_int l - let compare_part (p1 : Range.source * int * Tag.t block list) (p2 : Range.source * int * Tag.t block list) = - match p1, p2 with - | (_, pri1, _), (_, pri2, _) when pri1 <> pri2 -> Int.compare pri1 pri2 - | (s1, _, _), (s2, _, _) -> Option.compare String.compare (Range.title s1) (Range.title s2) + let compare_part (source1, priority1, _) (source2, priority2, _) = + Utils.compare_pair Int.compare (Option.compare String.compare) + (priority1, Range.title source1) (priority2, Range.title source2) - let flatten ~block_splitting_threshold ~blend rs = + let flatten ~block_splitting_threshold rs = rs |> List.fold_left add FileMap.empty |> FileMap.bindings - |> List.map (fun (src, rs) -> let rs = Bwd.to_list rs in src, priority rs, File.flatten ~block_splitting_threshold ~blend rs) - |> List.filter (fun (_, _, l) -> l <> []) (* filter out sources with only empty ranges *) + |> List.map + (fun (src, rs) -> + let rs = Bwd.to_list rs in + (src, priority rs, FileFlattener.flatten ~block_splitting_threshold rs)) |> List.stable_sort compare_part |> List.map (fun (src, _, part) -> src, part) end diff --git a/src/Flattener.mli b/src/Flattener.mli index 47f2b7f..21caba6 100644 --- a/src/Flattener.mli +++ b/src/Flattener.mli @@ -1,16 +1,17 @@ +open Explication + type 'tag block = { begin_line_num : int ; end_line_num : int - ; tagged_positions : ('tag option * Range.position) list - ; tagged_lines : ('tag * int) list + ; markers : (Range.position * 'tag marker) list + ; line_markers : (int * 'tag) list (* should be sorted by line numbers *) } type 'tag t = (Range.source * 'tag block list) list val dump_block : (Format.formatter -> 'tag -> unit) -> Format.formatter -> 'tag block -> unit - val dump : (Format.formatter -> 'tag -> unit) -> Format.formatter -> 'tag t -> unit module Make (Tag : ExplicatorSigs.Tag) : sig - val flatten : block_splitting_threshold:int -> blend:(Tag.t -> Tag.t -> Tag.t) -> (Tag.t * Range.t) list -> Tag.t t + val flatten : block_splitting_threshold:int -> (Range.t * Tag.t) list -> Tag.t t end diff --git a/src/Range.ml b/src/Range.ml index ba5ee35..4d36229 100644 --- a/src/Range.ml +++ b/src/Range.ml @@ -12,9 +12,7 @@ type position = { line_num : int; } -type t = - | Range of position * position - | End_of_file of position +type t = position * position type 'a located = { loc : t option; value : 'a } @@ -33,14 +31,7 @@ let dump_position fmt {source; offset; start_of_line; line_num} = Format.fprintf fmt {|@[<1>{@[<2>source=@[%a@]@];@ offset=%d;@ start_of_line=%d;@ line_num=%d}@]|} dump_source source offset start_of_line line_num -let dump fmt = - function - | Range (begin_, ending_) -> - Format.fprintf fmt {|@[<2>Range@ %a@]|} - (Utils.dump_pair dump_position dump_position) (begin_, ending_) - | End_of_file pos -> - Format.fprintf fmt {|@[<2>End_of_file@ %a@]|} - dump_position pos +let dump = Utils.dump_pair dump_position dump_position let title : source -> string option = function @@ -57,25 +48,20 @@ let make (begin_ , end_ : position * position) : t = invalid_arg @@ Format.asprintf "make: the ending position comes before the starting position" else - Range (begin_, end_) + (begin_, end_) -let eof pos = End_of_file pos +let eof pos = make (pos, pos) -let view = - function - | Range (p1, p2) -> `Range (p1, p2) - | End_of_file p -> `End_of_file p +let view (p1, p2) = + if p1 <> p2 then `Range (p1, p2) else `End_of_file p1 -let split = - function - | Range (p1, p2) -> p1, p2 - | End_of_file _ -> invalid_arg "Asai.Range.split" - -let source = function Range (x, _) | End_of_file x -> x.source -let begin_line_num = function Range (x, _) | End_of_file x -> x.line_num -let begin_offset = function Range (x, _) | End_of_file x -> x.offset -let end_line_num = function Range (_, x) | End_of_file x -> x.line_num -let end_offset = function Range (_, x) | End_of_file x -> x.offset +let split r = r + +let source (x, _) = x.source +let begin_line_num (x, _) = x.line_num +let begin_offset (x, _) = x.offset +let end_line_num (_, x) = x.line_num +let end_offset (_, x) = x.offset let locate_opt loc value = {loc; value} let locate loc value = {loc = Some loc; value} diff --git a/src/Range.mli b/src/Range.mli index 04b6082..cf173ff 100644 --- a/src/Range.mli +++ b/src/Range.mli @@ -50,22 +50,15 @@ type 'a located = { loc : t option; value : 'a } *) val make : position * position -> t -(** [eof pos] builds a special range referring to the end of the source. The input [pos] must be pointing at the end position; for example, if the position referring to a string source, [pos.offset] should be the length of the string. - - @since 0.3.0 -*) +(** [eof pos] builds a special range referring to the end of the source. The input [pos] must be pointing at the end position; for example, if the position referring to a string source, [pos.offset] should be the length of the string. *) val eof : position -> t +[@@ocaml.alert deprecated "Use Range.of_pos instead"] -(** [view range] returns a {i view} of the range. - - @since 0.3.0 -*) +(** [view range] returns a {i view} of the range. *) val view : t -> [`Range of position * position | `End_of_file of position] +[@@ocaml.alert deprecated "Use Range.split instead"] -(** [split range] returning the pair of the beginning and ending positions of [range]. It is the left-inverse of {!val:make}. - - @raise Invalid_argument if range is a special range marking the end of the source. See {!val:eof}. -*) +(** [split range] returning the pair of the beginning and ending positions of [range]. It is the left-inverse of {!val:make}. *) val split : t -> position * position (** [source range] returns the source associated with [range]. *) diff --git a/src/UserContent.ml b/src/UserContent.ml index 14e1323..c7a952d 100644 --- a/src/UserContent.ml +++ b/src/UserContent.ml @@ -80,13 +80,9 @@ let check_pos ~line_breaks ~eof read pos = raise @@ Invalid_position (`Incorrect_start_of_line (pos.start_of_line, new_pos.start_of_line)) let check_range ~line_breaks ~eof read range = - match Range.view range with - | `Range (p1, p2) -> - (try check_pos ~line_breaks ~eof read p1 with Invalid_position reason -> raise @@ Invalid_range (`Begin reason)); - (try check_pos ~line_breaks ~eof read p2 with Invalid_position reason -> raise @@ Invalid_range (`End reason)) - | `End_of_file p -> - if p.offset <> eof then raise @@ Invalid_range (`Not_end_of_file (p.offset, eof)); - (try check_pos ~line_breaks ~eof read p with Invalid_position reason -> raise @@ Invalid_range (`End_of_file reason)) + let p1, p2 = Range.split range in + (try check_pos ~line_breaks ~eof read p1 with Invalid_position reason -> raise @@ Invalid_range (`Begin reason)); + (try check_pos ~line_breaks ~eof read p2 with Invalid_position reason -> raise @@ Invalid_range (`End reason)) let replace_control ~tab_size str = let tab_string = String.make tab_size ' ' in diff --git a/src/UserContentData.ml b/src/UserContentData.ml index 86c1eb5..394d59a 100644 --- a/src/UserContentData.ml +++ b/src/UserContentData.ml @@ -16,6 +16,4 @@ type invalid_position = type invalid_range = [ `Begin of invalid_position (** The first position of a range is invalid. *) | `End of invalid_position (** The second position of a range is invalid. *) - | `End_of_file of invalid_position (** The range is a special end-of-file marking, but the position is invalid. *) - | `Not_end_of_file of int * int (** The range is a special end-of-file marking, but the offset of the position is not at the end of file. The pair [(m, n)] means that the current offset is [m] but the length or size of the source is [n]. *) ] diff --git a/src/Utils.ml b/src/Utils.ml index 795c15a..d175a46 100644 --- a/src/Utils.ml +++ b/src/Utils.ml @@ -11,9 +11,12 @@ let dump_option dump fmt = let dump_pair dump_x dump_y fmt (x, y) = Format.fprintf fmt {|@[<1>(%a,@ %a)@]|} dump_x x dump_y y +let dump_triple dump_x dump_y dump_z fmt (x, y, z) = + Format.fprintf fmt {|@[<1>(%a,@ %a,@ %a)@]|} dump_x x dump_y y dump_z z + let dump_list p fmt l = Format.fprintf fmt "@[[%a]@]" - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@,") p) + (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") p) l (* Currently note used @@ -62,6 +65,8 @@ let compare_pair c1 c2 (x1, y1) (x2, y2) : int = | 0 -> c2 y1 y2 | r -> r +let compare_opposite c x y = - c x y + let span p = let rec go acc = function diff --git a/src/tty/Ansi.ml b/src/tty/Ansi.ml index 2e5e597..c9d7bab 100644 --- a/src/tty/Ansi.ml +++ b/src/tty/Ansi.ml @@ -105,7 +105,7 @@ struct let guess ?use_ansi ?use_color o = if use_color = Some true && use_ansi = Some false then - invalid_arg "Ansi.Tty.display: called with use_color=true but use_ansi=false"; + 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} diff --git a/src/tty/Tty.ml b/src/tty/Tty.ml index 27ecd93..2a34588 100644 --- a/src/tty/Tty.ml +++ b/src/tty/Tty.ml @@ -43,13 +43,13 @@ let indentf ~param fmt = (* different parts of the display *) let render_code ~param ~severity fmt short_code = - let st = TtyStyle.code severity ~param in + let style = TtyStyle.code severity ~param in Format.fprintf fmt (" @<1>%s " ^^ highlight "%s[%s]" ^^ "@.") "→" - (Ansi.style_string ~param st) + (Ansi.style_string ~param style) (string_of_severity severity) short_code - (Ansi.reset_string ~param st) + (Ansi.reset_string ~param style) (* explication *) @@ -83,35 +83,57 @@ struct | None -> () | Some title -> Format.fprintf fmt " @<1>%s %s@." "■" title - let render_segment ~param fmt (tag, seg) = - let st = TtyStyle.highlight ~param:param.ansi param.severity tag in - Format.fprintf fmt (highlight "%s") - (Ansi.style_string ~param:param.ansi st) - (UserContent.replace_control ~tab_size:param.tab_size seg) - (Ansi.reset_string ~param:param.ansi st) - - let render_line_tag ~param fmt ((_, text) as tag) = - let st = TtyStyle.message ~param:param.ansi param.severity tag in + let render_line_marker ~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 "" (Ansi.style_string ~param:param.ansi TtyStyle.fringe) (Ansi.reset_string ~param:param.ansi TtyStyle.fringe) - (Ansi.style_string ~param:param.ansi st) + (Ansi.style_string ~param:param.ansi style) text - (Ansi.reset_string ~param:param.ansi st) + (Ansi.reset_string ~param:param.ansi style) - let render_line ~line_num ~param fmt Explication.{segments; tags} = + 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) + (UserContent.replace_control ~tab_size:param.tab_size segment) + (Ansi.reset_string ~param:param.ansi style) + + (* Current design: + + ‹let x◂POS₀▸ = 1› in let ‹x› = «1 + ‹x›»◂POS₁▸ + ‹let x◂POS₀▸ = 1›₀ in let ‹x›₁ = «1 + ‹x›₂»◂POS₁▸ + *) + + let render_line ~line_num ~param fmt init_tag_set Explication.{tokens; markers} = + let go set = + function + | Explication.String s -> + render_styled_segment ~param fmt (TtyTagSet.prioritized set) s; set + | Explication.Marker RangeEnd t -> + TtyTagSet.remove t set + | Explication.Marker Point t -> + render_styled_segment ~param fmt (Some t) "‹POS›"; set + | Explication.Marker RangeBegin t -> + TtyTagSet.add t set + 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); - List.iter (render_segment ~param fmt) segments; + let end_tag_set = List.fold_left go init_tag_set tokens in Format.fprintf fmt "@."; - List.iter (render_line_tag ~param fmt) tags + List.iter (render_line_marker ~param fmt) markers; + end_tag_set let render_lines ~param ~begin_line_num fmt lines = - lines |> List.iteri @@ fun i line -> - render_line ~line_num:(begin_line_num + i) ~param fmt line + 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) + lines let render_block ~param fmt Explication.{begin_line_num; end_line_num=_; lines} = render_lines ~param ~begin_line_num fmt lines @@ -125,12 +147,12 @@ struct end let render_unlocated_tag ~severity ~ansi fmt ((_, text) as tag) = - let st = TtyStyle.message ~param:ansi severity tag in + let style = TtyStyle.message ~param:ansi severity tag in Format.fprintf fmt (" @<1>%s " ^^ highlight "@[%t@]" ^^ "@.") "○" - (Ansi.style_string ~param:ansi st) + (Ansi.style_string ~param:ansi style) text - (Ansi.reset_string ~param:ansi st) + (Ansi.reset_string ~param:ansi style) module DiagnosticRenderer : sig @@ -173,7 +195,7 @@ struct List.partition_map (function | (tag, Range.{loc = None; value = text}) -> Either.Right (tag, text) - | (tag, Range.{loc = Some r; value = text}) -> Either.Left ((tag, text), r)) + | (tag, Range.{loc = Some r; value = text}) -> Either.Left (r, (tag, text))) (main :: extra_remarks) in let explication = diff --git a/src/tty/TtyTag.ml b/src/tty/TtyTag.ml index 132cc7e..f0928c5 100644 --- a/src/tty/TtyTag.ml +++ b/src/tty/TtyTag.ml @@ -4,6 +4,9 @@ let priority = function | Main, _ -> -1 | Extra 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" diff --git a/src/tty/TtyTagSet.ml b/src/tty/TtyTagSet.ml new file mode 100644 index 0000000..a0d3bb3 --- /dev/null +++ b/src/tty/TtyTagSet.ml @@ -0,0 +1,14 @@ +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/test/TestExplicator.ml b/test/TestExplicator.ml index 34b4d41..0cef458 100644 --- a/test/TestExplicator.ml +++ b/test/TestExplicator.ml @@ -7,21 +7,25 @@ let test_explication = Alcotest.of_pp (Explication.dump IntTag.dump) let single_line mode eol () = let source = `String {Range.title = None; content = "aaabbbcccdddeee" ^ eol} in let begin_of_line1 : Range.position = {source; offset = 0; start_of_line = 0; line_num = 1} in - let range1 = (1, "1"), Range.make ({begin_of_line1 with offset = 3}, {begin_of_line1 with offset = 9}) in - let range2 = (2, "2"), Range.make ({begin_of_line1 with offset = 6}, {begin_of_line1 with offset = 12}) in + let range1 = Range.make ({begin_of_line1 with offset = 3}, {begin_of_line1 with offset = 9}), (1, "1") in + let range2 = Range.make ({begin_of_line1 with offset = 6}, {begin_of_line1 with offset = 12}), (2, "2") in let expected : _ Explication.t = [{source; blocks = [{begin_line_num = 1; end_line_num = 1; lines = - [{tags = [(1, "1"); (2, "2")]; - segments = - [(None, "aaa"); - (Some (1, "1"), "bbb"); - (Some (2, "2"), "ccc"); - (Some (2, "2"), "ddd"); - (None, "eee"); + [{markers = [(1, "1"); (2, "2")]; + tokens = + [String "aaa"; + Marker (RangeBegin (1, "1")); + String "bbb"; + Marker (RangeBegin (2, "2")); + String "ccc"; + Marker (RangeEnd (1, "1")); + String "ddd"; + Marker (RangeEnd (2, "2")); + String "eee"; ]}]} ]} ] in @@ -32,22 +36,24 @@ let multi_lines_with_ls () = let source = `String {Range.title = None; content = "aabbbbb\u{2028}bbbbccc"} in let begin_of_line1 : Range.position = {source; offset = 0; start_of_line = 0; line_num = 1} in let begin_of_line2 : Range.position = {source; offset = 10; start_of_line = 10; line_num = 2} in - let range = (1, "1"), Range.make ({begin_of_line1 with offset = 2}, {begin_of_line2 with offset = 14}) in + let range = Range.make ({begin_of_line1 with offset = 2}, {begin_of_line2 with offset = 14}), (1, "1") in let expected : _ Explication.t = [{source; blocks = [{begin_line_num = 1; end_line_num = 2; lines = - [{tags=[]; - segments= - [(None, "aa"); - (Some (1, "1"), "bbbbb"); + [{markers=[]; + tokens= + [String "aa"; + Marker (RangeBegin (1, "1")); + String "bbbbb"; ]}; - {tags=[(1, "1")]; - segments= - [(Some (1, "1"), "bbbb"); - (None, "ccc"); + {markers=[(1, "1")]; + tokens= + [String "bbbb"; + Marker (RangeEnd (1, "1")); + String "ccc"; ]}]} ]} ] @@ -83,11 +89,11 @@ ggggghh let begin_of_line15 : Range.position = {source; offset = 51; start_of_line = 51; line_num = 15} in let ranges = [ - (2, "1"), Range.make ({begin_of_line4 with offset = 17+1}, {begin_of_line4 with offset = 17+4}); - (1, "2"), Range.make ({begin_of_line2 with offset = 1+2}, {begin_of_line4 with offset = 17+4}); - (4, "3"), Range.make ({begin_of_line9 with offset = 33+2}, {begin_of_line9 with offset = 33+7}); - (8, "4"), Range.make ({begin_of_line9 with offset = 33+4}, {begin_of_line9 with offset = 33+7}); - (16, "5"), Range.make (begin_of_line15, {begin_of_line15 with offset = 51+5}); + Range.make ({begin_of_line4 with offset = 17+1}, {begin_of_line4 with offset = 17+4}), (2, "1"); + Range.make ({begin_of_line2 with offset = 1+2}, {begin_of_line4 with offset = 17+4}), (1, "2"); + Range.make ({begin_of_line9 with offset = 33+2}, {begin_of_line9 with offset = 33+7}), (4, "3"); + Range.make ({begin_of_line9 with offset = 33+4}, {begin_of_line9 with offset = 33+7}), (8, "4"); + Range.make (begin_of_line15, {begin_of_line15 with offset = 51+5}), (16, "5"); ] in let expected : _ Explication.t = @@ -96,42 +102,52 @@ ggggghh [{begin_line_num=2; end_line_num=9; lines= - [{tags=[]; - segments= - [(None, "aa"); - (Some (1, "2"), "bbbbb")]}; - {tags=[]; - segments= - [(Some (1, "2"), "bbbbbbb")]}; - {tags=[(1, "2"); (2, "1")]; - segments= - [(Some (1, "2"), "b"); - (Some (2, "1"), "*cc"); - (None, "ddd")]}; - {tags=[]; - segments= - [(None, "1")]}; - {tags=[]; - segments= - [(None, "2")]}; - {tags=[]; - segments= - [(None, "3")]}; - {tags=[]; - segments= - [(None, "4")]}; - {tags=[(4, "3"); (8, "4")]; - segments= - [(None, "ee"); - (Some (4, "3"), "++"); - (Some (8, "4"), "fff")]}]}; + [{markers=[]; + tokens= + [String "aa"; + Marker (RangeBegin (1, "2")); + String "bbbbb"]}; + {markers=[]; + tokens= + [String "bbbbbbb"]}; + {markers=[(2, "1"); (1, "2")]; + tokens= + [String "b"; + Marker (RangeBegin (2, "1")); + String "*cc"; + Marker (RangeEnd (2, "1")); + Marker (RangeEnd (1, "2")); + String "ddd"]}; + {markers=[]; + tokens= + [String "1"]}; + {markers=[]; + tokens= + [String "2"]}; + {markers=[]; + tokens= + [String "3"]}; + {markers=[]; + tokens= + [String "4"]}; + {markers=[(8, "4"); (4, "3")]; + tokens= + [String "ee"; + Marker (RangeBegin (4, "3")); + String "++"; + Marker (RangeBegin (8, "4")); + String "fff"; + Marker (RangeEnd (8, "4")); + Marker (RangeEnd (4, "3"))]}]}; {begin_line_num=15; end_line_num=15; lines= - [{tags=[(16, "5")]; - segments= - [(Some (16, "5"), "ggggg"); - (None, "hh")]}]}]}] + [{markers=[(16, "5")]; + tokens= + [Marker (RangeBegin (16, "5")); + String "ggggg"; + Marker (RangeEnd (16, "5")); + String "hh"]}]}]}] in let actual = E.explicate ~line_breaks:`Traditional ~block_splitting_threshold:5 ranges in Alcotest.(check test_explication) "Explication is correct" expected actual diff --git a/test/TestFlattener.ml b/test/TestFlattener.ml index 68f9625..0c99471 100644 --- a/test/TestFlattener.ml +++ b/test/TestFlattener.ml @@ -15,20 +15,29 @@ let single_line_flatten () = {begin_of_line1 with offset = 12} in let ranges = - [ (1, "1"), Range.make (pt1, pt3) - ; (2, "2"), Range.make (pt1, pt3) - ; (1, "3"), Range.make (pt1, pt3) - ; (3, "4"), Range.make (pt2, pt4) + [ Range.make (pt1, pt3), (1, "1") + ; Range.make (pt1, pt3), (2, "2") + ; Range.make (pt1, pt3), (1, "3") + ; Range.make (pt2, pt4), (3, "4") ] in let expected : _ Flattener.t = [(source, [{begin_line_num=1; end_line_num=1; - tagged_positions=[(Some (2, "2"), pt1);(Some (3, "4"), pt2);(Some (3, "4"), pt3);(None, pt4)]; - tagged_lines=[((2, "2"), 1); ((1, "1"), 1); ((1, "3"), 1); ((3, "4"), 1)]}])] + markers= + [ pt1, RangeBegin (1, "3") + ; pt1, RangeBegin (1, "1") + ; pt1, RangeBegin (2, "2") + ; pt2, RangeBegin (3, "4") + ; pt3, RangeEnd (2, "2") + ; pt3, RangeEnd (1, "1") + ; pt3, RangeEnd (1, "3") + ; pt4, RangeEnd (3, "4") + ]; + line_markers=[(1, (2, "2")); (1, (1, "1")); (1, (1, "3")); (1, (3, "4"))]}])] in - let actual = F.flatten ~block_splitting_threshold:5 ~blend:(Explicator.default_blend ~priority:IntTag.priority) ranges in + let actual = F.flatten ~block_splitting_threshold:5 ranges in Alcotest.(check test_flattened) "Flattener is correct" expected actual let multi_lines () = @@ -64,38 +73,42 @@ ggggghh in let ranges = [ - (2, "1"), Range.make (pt18, pt21); - (1, "2"), Range.make (pt3, pt21); - (4, "3"), Range.make (pt35, pt40); - (8, "4"), Range.make (pt37, pt40); - (16, "5"), Range.make (begin_of_line15, pt56); + Range.make (pt18, pt21), (2, "1"); + Range.make (pt3, pt21), (1, "2"); + Range.make (pt35, pt40), (4, "3"); + Range.make (pt37, pt40), (8, "4"); + Range.make (begin_of_line15, pt56), (16, "5"); ] in let expected : _ Flattener.t = [(source, [{begin_line_num=2; end_line_num=9; - tagged_positions= - [(Some (1, "2"), pt3); - (Some (2, "1"), pt18); - (None, pt21); - (Some (4, "3"), pt35); - (Some (8, "4"), pt37); - (None, pt40)]; - tagged_lines= - [((1, "2"), 4); - ((2, "1"), 4); - ((4, "3"), 9); - ((8, "4"), 9)]}; + markers= + [(pt3, RangeBegin (1, "2")); + (pt18, RangeBegin (2, "1")); + (pt21, RangeEnd (2, "1")); + (pt21, RangeEnd (1, "2")); + (pt35, RangeBegin (4, "3")); + (pt37, RangeBegin (8, "4")); + (pt40, RangeEnd (8, "4")); + (pt40, RangeEnd (4, "3")); + ]; + line_markers= + [ 4, (2, "1") + ; 4, (1, "2") + ; 9, (8, "4") + ; 9, (4, "3") + ]}; {begin_line_num=15; end_line_num=15; - tagged_positions= - [(Some (16, "5"), begin_of_line15); - (None, pt56)]; - tagged_lines= - [((16, "5"), 15)]}])] + markers= + [(begin_of_line15, RangeBegin (16, "5")); + (pt56, RangeEnd (16, "5"))]; + line_markers= + [(15, (16, "5"))]}])] in - let actual = F.flatten ~block_splitting_threshold:5 ~blend:(Explicator.default_blend ~priority:IntTag.priority) ranges in + let actual = F.flatten ~block_splitting_threshold:5 ranges in Alcotest.(check test_flattened) "Flattener is correct" expected actual let () = diff --git a/test/TestTty.expected b/test/TestTty.expected index 84e14b8..9091b4b 100644 --- a/test/TestTty.expected +++ b/test/TestTty.expected @@ -101,16 +101,16 @@ ^ message 7  3 | cccccccccc ^ message 2 - 10 | jjjjjjjjjj + 10 | ‹POS›jjjjjjjjjj ^ message 8 ○ message 1 ○ message 3 → warning[hello] - 23 | wwwwwwwwww‹EOF› + 23 | wwwwwwwwww‹POS› ^ this is the main message ■ /path/to/file.cool - 23 | wwwwwwwwww‹EOF› + 23 | wwwwwwwwww‹POS› ^ ending of another file → warning[hello] @@ -216,16 +216,16 @@ ^ message 7  3 | cccccccccc ^ message 2 - 10 | jjjjjjjjjj + 10 | ‹POS›jjjjjjjjjj ^ message 8 ○ message 1 ○ message 3 → warning[hello] - 23 | wwwwwwwwww‹EOF› + 23 | wwwwwwwwww‹POS› ^ this is the main message ■ /path/to/file.cool - 23 | wwwwwwwwww‹EOF› + 23 | wwwwwwwwww‹POS› ^ ending of another file → warning[hello] @@ -331,15 +331,15 @@ ^ message 7 3 | cccccccccc ^ message 2 - 10 | jjjjjjjjjj + 10 | ‹POS›jjjjjjjjjj ^ message 8 ○ message 1 ○ message 3 → warning[hello] - 23 | wwwwwwwwww‹EOF› + 23 | wwwwwwwwww‹POS› ^ this is the main message ■ /path/to/file.cool - 23 | wwwwwwwwww‹EOF› + 23 | wwwwwwwwww‹POS› ^ ending of another file diff --git a/test/TestTty.ml b/test/TestTty.ml index 72e99f1..b90da4d 100644 --- a/test/TestTty.ml +++ b/test/TestTty.ml @@ -79,9 +79,9 @@ let exec handler = Loctext.make ~loc:(Range.make (~@ s2 10 0, ~@ s2 10 0)) "message 8"; ]; - Reporter.emit ~loc:(Range.eof (~@ s1 23 width)) Hello "this is the main message" + Reporter.emit ~loc:(Range.make (~@ s1 23 width, ~@ s1 23 width)) Hello "this is the main message" ~extra_remarks:[ - Loctext.make ~loc:(Range.eof (~@ s2 23 width)) "ending of another file"; + Loctext.make ~loc:(Range.make (~@ s2 23 width, ~@ s2 23 width)) "ending of another file"; ] let () =