Fix #9116: Error source highlighting in presence of tabs

.gitattributes

@@ -109,6 +109,7 @@ testsuite/tests/win-unicode/*.ml                        typo.utf8
 testsuite/tools/*.S                                     typo.missing-header
 testsuite/tools/*.asm                                   typo.missing-header
 testsuite/typing                                        typo.missing-header
+testsuite/tests/messages/highlight_tabs.ml              typo.tab
 
 # prune testsuite reference files
 testsuite/tests/**/*.reference               typo.prune

Changes

@@ -45,6 +45,10 @@ Working version
 - #9107: improved error message for exceptions in module signature errors
   (Gabriel Scherer, review by Florian Angeletti)
 
+- #9116, #9118: fix error highlighting code in presence of tabulations
+  in the source code
+  (Armaël Guéneau, review by Gabriel Scherer, report by Ricardo M. Correia)
+
 ### Internal/compiler-libs changes:
 
 - #8970: separate value patterns (matching on values) from computation patterns

parsing/location.ml

@@ -463,23 +463,61 @@ let highlight_quote ppf
         (* Single-line error *)
         Format.fprintf ppf "%s | %s@," line_nb line;
         Format.fprintf ppf "%*s   " (String.length line_nb) "";
-        for pos = line_start_cnum to rightmost.pos_cnum - 1 do
+        String.iteri (fun i c ->
+          let pos = line_start_cnum + i in
           if ISet.is_start iset ~pos <> None then
             Format.fprintf ppf "@{<%s>" highlight_tag;
           if ISet.mem iset ~pos then Format.pp_print_char ppf '^'
-          else Format.pp_print_char ppf ' ';
+          else if pos < rightmost.pos_cnum then begin
+            (* For alignment purposes, align using a tab for each tab in the
+               source code *)
+            if c = '\t' then Format.pp_print_char ppf '\t'
+            else Format.pp_print_char ppf ' '
+          end;
           if ISet.is_end iset ~pos <> None then
             Format.fprintf ppf "@}"
-        done;
+        ) line;
         Format.fprintf ppf "@}@,"
     | _ ->
         (* Multi-line error *)
         Misc.pp_two_columns ~sep:"|" ~max_lines ppf
         @@ List.map (fun (line, line_nb, line_start_cnum) ->
-          let line = String.mapi (fun i car ->
-            if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.'
-          ) line in
-          (line_nb, line)
+          (* whether a character should be displayed or discarded *)
+          let is_show i =
+            ISet.mem iset ~pos:(line_start_cnum + i)
+            (* for alignment purposes, display tabs as themselves
+               instead of replacing them by a space *)
+            || line.[i] = '\t'
+          in
+          let line = Bytes.of_string line in
+          (* Replace characters that do not satisfy [is_show] with spaces *)
+          for i = 0 to Bytes.length line - 1 do
+            if not (is_show i) then Bytes.set line i ' '
+          done;
+          (* Insert an ellipsis marker if possible *)
+          let (--^) i j = List.init (max 0 (j-i-1)) ((+) i) in
+          let insert_ellipsis b (side: [`Before | `After]) idx =
+            let ellipsis_before = "... " and ellipsis_after = " ..." in
+            let i, j, ellipsis = match side with
+              | `Before ->
+                  idx - String.length ellipsis_before, idx, ellipsis_before
+              | `After ->
+                  idx+1, idx+1 + String.length ellipsis_after, ellipsis_after in
+            let i = max 0 i in
+            let j = min (Bytes.length b) j in
+            if j - i = String.length ellipsis &&
+               List.for_all (Fun.negate is_show) (i --^ j) then
+              Bytes.blit_string ellipsis 0 line i (String.length ellipsis)
+          in
+          (* Insert ellipsis markers before and after locations when possible *)
+          for i = 0 to Bytes.length line - 1 do
+            let pos = line_start_cnum + i in
+            if ISet.is_start iset ~pos <> None then
+              insert_ellipsis line `Before i
+            else if ISet.is_end iset ~pos <> None then
+              insert_ellipsis line `After i
+          done;
+          (line_nb, Bytes.to_string line)
         ) lines
     end;
     Format.fprintf ppf "@]"

testsuite/tests/basic-modules/recursive_module_evaluation_errors.ml

@@ -64,7 +64,7 @@ end
 and B: sig val value: unit end = struct let value = A.f () end
 [%%expect {|
 Lines 4-7, characters 6-3:
-4 | ......struct
+4 |   ... struct
 5 |   module F(X:sig end) = struct end
 6 |   let f () = B.value
 7 | end
@@ -94,7 +94,7 @@ module F(X: sig module type t module M: t end) = struct
 end
 [%%expect {|
 Lines 5-8, characters 8-5:
-5 | ........struct
+5 |     ... struct
 6 |     module M = X.M
 7 |     let f () = B.value
 8 |   end

testsuite/tests/basic-more/morematch.compilers.reference

@@ -43,7 +43,7 @@ File "morematch.ml", line 456, characters 2-7:
         ^^^^^
 Warning 11: this match case is unused.
 File "morematch.ml", lines 1050-1053, characters 8-10:
-1050 | ........function
+1050 |     ... function
 1051 |   | A (`A|`C) -> 0
 1052 |   | B (`B,`D) -> 1
 1053 |   | C -> 2

testsuite/tests/basic-more/robustmatch.compilers.reference

@@ -1,5 +1,5 @@
 File "robustmatch.ml", lines 33-37, characters 6-23:
-33 | ......match t1, t2, x with
+33 |   ... match t1, t2, x with
 34 |       | AB, AB, A -> ()
 35 |       | MAB, _, A -> ()
 36 |       | _,  AB, B -> ()
@@ -8,186 +8,186 @@ Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (AB, MAB, A)
 File "robustmatch.ml", lines 54-56, characters 4-27:
-54 | ....match r1, r2, a with
+54 | ... match r1, r2, a with
 55 |     | R1, _, 0 -> ()
 56 |     | _, R2, "coucou" -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, 1)
 File "robustmatch.ml", lines 64-66, characters 4-27:
-64 | ....match r1, r2, a with
+64 | ... match r1, r2, a with
 65 |     | R1, _, A -> ()
 66 |     | _, R2, "coucou" -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, (B|C))
 File "robustmatch.ml", lines 69-71, characters 4-20:
-69 | ....match r1, r2, a with
+69 | ... match r1, r2, a with
 70 |     | _, R2, "coucou" -> ()
 71 |     | R1, _, A -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, (B|C))
 File "robustmatch.ml", lines 74-76, characters 4-20:
-74 | ....match r1, r2, a with
+74 | ... match r1, r2, a with
 75 |     | _, R2, "coucou" -> ()
 76 |     | R1, _, _ -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, "")
 File "robustmatch.ml", lines 85-87, characters 4-20:
-85 | ....match r1, r2, a with
+85 | ... match r1, r2, a with
 86 |     | R1, _, A -> ()
 87 |     | _, R2, X -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, (B|C))
 File "robustmatch.ml", lines 90-93, characters 4-20:
-90 | ....match r1, r2, a with
+90 | ... match r1, r2, a with
 91 |     | R1, _, A -> ()
 92 |     | _, R2, X -> ()
 93 |     | R1, _, _ -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, (Y|Z))
 File "robustmatch.ml", lines 96-98, characters 4-20:
-96 | ....match r1, r2, a with
+96 | ... match r1, r2, a with
 97 |     | R1, _, _ -> ()
 98 |     | _, R2, X -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, (Y|Z))
 File "robustmatch.ml", lines 107-109, characters 4-20:
-107 | ....match r1, r2, a with
+107 | ... match r1, r2, a with
 108 |     | R1, _, A -> ()
 109 |     | _, R2, X -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, (B|C))
 File "robustmatch.ml", lines 129-131, characters 4-20:
-129 | ....match r1, r2, a with
+129 | ... match r1, r2, a with
 130 |     | R1, _, A -> ()
 131 |     | _, R2, X -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, B)
 File "robustmatch.ml", lines 151-153, characters 4-20:
-151 | ....match r1, r2, a with
+151 | ... match r1, r2, a with
 152 |     | R1, _, A -> ()
 153 |     | _, R2, X -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, B)
 File "robustmatch.ml", lines 156-159, characters 4-20:
-156 | ....match r1, r2, a with
+156 | ... match r1, r2, a with
 157 |     | R1, _, A -> ()
 158 |     | _, R2, X -> ()
 159 |     | R1, _, _ -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, Y)
 File "robustmatch.ml", lines 162-164, characters 4-20:
-162 | ....match r1, r2, a with
+162 | ... match r1, r2, a with
 163 |     | R1, _, _ -> ()
 164 |     | _, R2, X -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, Y)
 File "robustmatch.ml", lines 167-169, characters 4-20:
-167 | ....match r1, r2, a with
+167 | ... match r1, r2, a with
 168 |     | R1, _, C -> ()
 169 |     | _, R2, Y -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, A)
 File "robustmatch.ml", lines 176-179, characters 4-20:
-176 | ....match r1, r2, a with
+176 | ... match r1, r2, a with
 177 |     | _, R1, 0 -> ()
 178 |     | R2, _, [||] -> ()
 179 |     | _, R1, 1 -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, [| _ |])
 File "robustmatch.ml", lines 182-184, characters 4-23:
-182 | ....match r1, r2, a with
+182 | ... match r1, r2, a with
 183 |     | R1, _, _ -> ()
 184 |     | _, R2, [||] -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, [| _ |])
 File "robustmatch.ml", lines 187-190, characters 4-20:
-187 | ....match r1, r2, a with
+187 | ... match r1, r2, a with
 188 |     | _, R2, [||] -> ()
 189 |     | R1, _, 0 -> ()
 190 |     | R1, _, _ -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, [| _ |])
 File "robustmatch.ml", lines 200-203, characters 4-19:
-200 | ....match r1, r2, a with
+200 | ... match r1, r2, a with
 201 |     | _, R2, [||] -> ()
 202 |     | R1, _, 0 -> ()
 203 |     | _, _, _ -> ()
 Warning 4: this pattern-matching is fragile.
 It will remain exhaustive when constructors are added to type repr.
 File "robustmatch.ml", lines 210-212, characters 4-27:
-210 | ....match r1, r2, a with
+210 | ... match r1, r2, a with
 211 |     | R1, _, 'c' -> ()
 212 |     | _, R2, "coucou" -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, 'a')
 File "robustmatch.ml", lines 219-221, characters 4-27:
-219 | ....match r1, r2, a with
+219 | ... match r1, r2, a with
 220 |     | R1, _, `A -> ()
 221 |     | _, R2, "coucou" -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, `B)
 File "robustmatch.ml", lines 228-230, characters 4-37:
-228 | ....match r1, r2, a with
+228 | ... match r1, r2, a with
 229 |     | R1, _, (3, "") -> ()
 230 |     | _, R2, (1, "coucou", 'a') -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, (3, "*"))
 File "robustmatch.ml", lines 239-241, characters 4-51:
-239 | ....match r1, r2, a with
+239 | ... match r1, r2, a with
 240 |     | R1, _, { x = 3; y = "" } -> ()
 241 |     | _, R2, { a = 1; b = "coucou"; c = 'a' } -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, {x=3; y="*"})
 File "robustmatch.ml", lines 244-246, characters 4-36:
-244 | ....match r1, r2, a with
+244 | ... match r1, r2, a with
 245 |     | R2, _, { a = 1; b = "coucou"; c = 'a' } -> ()
 246 |     | _, R1, { x = 3; y = "" } -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R2, R2, {a=1; b="coucou"; c='b'})
 File "robustmatch.ml", lines 253-255, characters 4-20:
-253 | ....match r1, r2, a with
+253 | ... match r1, r2, a with
 254 |     | R1, _, (3, "") -> ()
 255 |     | _, R2, 1 -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, (3, "*"))
 File "robustmatch.ml", lines 263-265, characters 4-20:
-263 | ....match r1, r2, a with
+263 | ... match r1, r2, a with
 264 |     | R1, _, { x = 3; y = "" } -> ()
 265 |     | _, R2, 1 -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, {x=3; y="*"})
 File "robustmatch.ml", lines 272-274, characters 4-20:
-272 | ....match r1, r2, a with
+272 | ... match r1, r2, a with
 273 |     | R1, _, lazy 1 -> ()
 274 |     | _, R2, 1 -> ()
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a case that is not matched:
 (R1, R1, lazy 0)
 File "robustmatch.ml", lines 281-284, characters 4-24:
-281 | ....match r1, r2, a with
+281 | ... match r1, r2, a with
 282 |     | R1, _, () -> ()
 283 |     | _, R2, "coucou" -> ()
 284 |     | _, R2, "foo" -> ()

testsuite/tests/generalized-open/gpr1506.ml

@@ -116,7 +116,7 @@ module A = struct
 end
 [%%expect{|
 Lines 3-6, characters 4-7:
-3 | ....open struct
+3 | ... open struct
 4 |       type t = T
 5 |       let x = T
 6 |     end
@@ -136,7 +136,7 @@ module A = struct
 end
 [%%expect{|
 Lines 3-5, characters 4-7:
-3 | ....open struct
+3 | ... open struct
 4 |       type t = T
 5 |     end
 Error: The type t/159 introduced by this open appears in the signature

testsuite/tests/let-syntax/let_syntax.ml

@@ -291,9 +291,9 @@ let ill_typed_5 =
   );;
 [%%expect{|
 Lines 3-5, characters 9-14:
-3 | .........x = 1
+3 |      ... x = 1
 4 |     and+ y = 2
-5 |     and+ z = 3...
+5 |     and+ z = 3
 Error: These bindings have type (int * int) * int
        but bindings were expected of type bool
 |}];;
@@ -321,7 +321,7 @@ let ill_typed_6 =
   );;
 [%%expect{|
 Lines 3-4, characters 9-14:
-3 | .........x = 1
+3 |      ... x = 1
 4 |     and+ y = 2
 Error: These bindings have type int * int but bindings were expected of type
          int
@@ -513,7 +513,7 @@ let indexed_monad4 =
   );;
 [%%expect{|
 Lines 6-7, characters 4-29:
-6 | ....let* second = read in
+6 | ... let* second = read in
 7 |       return (first ^ second)
 Error: This expression has type
          (Indexed_monad.opened, Indexed_monad.opened, string) Indexed_monad.t