Location: generalize [highlight_dumb] to handle several locations

parsing/location.ml

@@ -94,8 +94,10 @@ let print_updating_num_loc_lines ppf f arg =
   pp_print_flush ppf ();
   pp_set_formatter_out_functions ppf out_functions
 
-(* Highlight the locations using standout mode. *)
+(* Highlight the locations using standout mode.
 
+   If [locs] is empty, this function is a no-op.
+*)
 let highlight_terminfo ppf lb locs =
   Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
   (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
@@ -130,78 +132,109 @@ let highlight_terminfo ppf lb locs =
   Terminfo.resume stdout !num_loc_lines;
   flush stdout
 
-(* Highlight the location by printing it again. *)
+(* Highlight the location by printing it again.
 
-let highlight_dumb ~print_chars ppf lb loc =
-  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
-  let pos0 = -lb.lex_abs_pos in
-  (* Do nothing if the buffer does not contain the whole phrase. *)
-  if pos0 < 0 then raise Exit;
-  let end_pos = lb.lex_buffer_len - pos0 - 1 in
-  (* Determine line numbers for the start and end points *)
-  let line_start = ref 0 and line_end = ref 0 in
-  for pos = 0 to end_pos do
-    if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin
-      if loc.loc_start.pos_cnum > pos then incr line_start;
-      if loc.loc_end.pos_cnum   > pos then incr line_end;
-    end
-  done;
-  Format.fprintf ppf "@[<v>";
-  (* Print character location (useful for Emacs) *)
-  if print_chars then begin
-    Format.fprintf ppf "Characters %i-%i:@,"
-                   loc.loc_start.pos_cnum loc.loc_end.pos_cnum
-  end;
-  (* Print the input, underlining the location *)
-  Format.pp_print_string ppf "  ";
-  let line = ref 0 in
-  let pos_at_bol = ref 0 in
-  for pos = 0 to end_pos do
-    match Bytes.get lb.lex_buffer (pos + pos0) with
-    | '\n' ->
-      if !line = !line_start && !line = !line_end then begin
-        (* loc is on one line: underline location *)
-        Format.fprintf ppf "@,  ";
-        for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
-          Format.pp_print_char ppf ' '
-        done;
-        for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
-          Format.pp_print_char ppf '^'
-        done
-      end;
-      if !line >= !line_start && !line <= !line_end then begin
-        Format.fprintf ppf "@,";
-        if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf "  "
-      end;
-      incr line;
-      pos_at_bol := pos + 1
-    | '\r' -> () (* discard *)
-    | c ->
-      if !line = !line_start && !line = !line_end then
-        (* loc is on one line: print whole line *)
-        Format.pp_print_char ppf c
-      else if !line = !line_start then
-        (* first line of multiline loc:
-           print a dot for each char before loc_start *)
-        if pos < loc.loc_start.pos_cnum then
-          Format.pp_print_char ppf '.'
-        else
-          Format.pp_print_char ppf c
-      else if !line = !line_end then
-        (* last line of multiline loc: print a dot for each char
-           after loc_end, even whitespaces *)
-        if pos < loc.loc_end.pos_cnum then
+   There are two different styles for highlighting errors in "dumb" mode,
+   depending if the error fits on a single line or spans across several lines.
+
+   For single-line errors,
+
+     foo the_error bar
+
+   gets displayed as:
+
+     foo the_error bar
+         ^^^^^^^^^
+
+
+   For multi-line errors,
+
+     foo the_
+     error bar
+
+   gets displayed as:
+
+     ....the_
+     error....
+
+   If [locs] is empty then this function is a no-op.
+*)
+let highlight_dumb ~print_chars ppf lb locs =
+  if locs = [] then ()
+  else begin
+    let locs = List.map (fun loc ->
+      (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum)
+    ) locs in
+    (* Helper to check if a given position is to be highlighted *)
+    let is_highlighted pos =
+      List.exists (fun (s, e) -> s <= pos && pos < e) locs in
+    (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
+    let pos0 = -lb.lex_abs_pos in
+    (* Helper to read a char in the buffer *)
+    let read_char pos = Bytes.get lb.lex_buffer (pos + pos0) in
+    (* Do nothing if the buffer does not contain the whole phrase. *)
+    if pos0 < 0 then raise Exit;
+    let end_pos = lb.lex_buffer_len - pos0 - 1 in
+    (* Leftmost starting position of all locations *)
+    let leftmost_start, _ =
+      List.hd @@ List.sort (fun (s, _) (s', _) -> compare s s') locs in
+    (* Rightmost ending position of all locations *)
+    let _, rightmost_end =
+      List.hd @@ List.sort (fun (_, e) (_, e') -> compare e' e) locs in
+    (* Determine line numbers for the start and end points *)
+    let line_start, line_end =
+      let line_start = ref 0 and line_end = ref 0 in
+      for pos = 0 to end_pos do
+        if read_char pos = '\n' then begin
+          if leftmost_start > pos then incr line_start;
+          if rightmost_end  > pos then incr line_end;
+        end
+      done;
+      !line_start, !line_end
+    in
+    Format.fprintf ppf "@[<v>";
+    (* Print character location (useful for Emacs) *)
+    if print_chars then begin
+      Format.fprintf ppf "Characters %i-%i:@,"
+        leftmost_start rightmost_end
+    end;
+    (* Print the input, highlighting the locations.
+       Indent by two spaces. *)
+    Format.fprintf ppf "  @[<v>";
+    let line = ref 0 in
+    let pos_at_bol = ref 0 in
+    for pos = 0 to end_pos do
+      match read_char pos with
+      | '\n' ->
+        if !line = line_start && !line = line_end then begin
+          (* single-line error: underline the locations *)
+          Format.fprintf ppf "@,";
+          for i = !pos_at_bol to rightmost_end - 1 do
+            if is_highlighted i then Format.pp_print_char ppf '^'
+            else Format.pp_print_char ppf ' '
+          done;
+        end;
+        if !line >= line_start && !line < line_end then begin
+          Format.fprintf ppf "@,";
+        end;
+        incr line;
+        pos_at_bol := pos + 1
+      | '\r' -> () (* discard *)
+      | c ->
+        if !line = line_start && !line = line_end then
+          (* single-line error: print the whole line *)
           Format.pp_print_char ppf c
-        else
-          Format.pp_print_char ppf '.'
-      else if !line > !line_start && !line < !line_end then
-        (* intermediate line of multiline loc: print whole line *)
-        Format.pp_print_char ppf c
-  done;
-  Format.fprintf ppf "@]"
+        else if line_start <= !line && !line <= line_end then begin
+          (* multi-line error *)
+          if is_highlighted pos then Format.pp_print_char ppf c
+          else Format.pp_print_char ppf '.'
+        end
+    done;
+    Format.fprintf ppf "@]@,@]"
+  end
 
-let show_code_at_location ppf lb loc =
-  highlight_dumb ~print_chars:false ppf lb loc
+let show_code_at_location ppf lb locs =
+  highlight_dumb ~print_chars:false ppf lb locs
 
 (* Highlight the location using one of the supported modes. *)
 
@@ -216,8 +249,7 @@ let rec highlight_locations ppf locs =
           let norepeat =
             try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
           if norepeat then false else
-            let loc1 = List.hd locs in
-            try highlight_dumb ~print_chars:true ppf lb loc1; true
+            try highlight_dumb ~print_chars:true ppf lb locs; true
             with Exit -> false
       end
   | Terminfo.Good_term ->

parsing/location.mli

@@ -77,7 +77,7 @@ val default_warning_printer : t -> formatter -> Warnings.t -> unit
 
 val highlight_locations: formatter -> t list -> bool
 
-val show_code_at_location: formatter -> Lexing.lexbuf -> t -> unit
+val show_code_at_location: formatter -> Lexing.lexbuf -> t list -> unit
 
 type 'a loc = {
   txt : 'a;

testsuite/tools/expect_test.ml

@@ -141,7 +141,7 @@ module Compiler_messages = struct
       begin match !Location.input_lexbuf with
       | None -> ()
       | Some lexbuf ->
-         Location.show_code_at_location ppf lexbuf loc
+         Location.show_code_at_location ppf lexbuf [loc]
       end;
     ()