Fix color highlight for errors.

The output from the compiler changed and now mentions the line number
(non only the charters, which actually becomes columns). This patch
introduces the idea of a range of lines spanned by an error and
correctly marks the faulty region.

I think a better solution would be to introduce a "point" record of
the form {line:int;column:int}. However, such a change would
reverberate through all the source code and so it is much more
invasive. I can prepare such a patch if desired, after this one, which
fixes the regression.

src/lib/uTop.ml

@@ -103,6 +103,15 @@ let default_keywords = [
 let keywords = ref (String_set.of_list default_keywords)
 let add_keyword kwd = keywords := String_set.add kwd !keywords
 
+(* +-----------------------------------------------------------------+
+   | Span of Lines                                                   |
+   +-----------------------------------------------------------------+ *)
+
+type lines = {
+  start: int;
+  stop:  int;
+}
+
 (* +-----------------------------------------------------------------+
    | Error reporting                                                 |
    +-----------------------------------------------------------------+ *)
@@ -126,9 +135,22 @@ let get_ocaml_error_message exn =
     Scanf.sscanf
       str
       "Characters %d-%d:\n%[\000-\255]"
-      (fun start stop msg -> ((start, stop), msg))
-  with _ ->
-    ((0, 0), str)
+      (fun start stop msg -> ((start, stop), msg, None))
+  with Scanf.Scan_failure(_) ->
+  try
+    Scanf.sscanf
+      str
+      "Line %d, characters %d-%d:\n%[\000-\255]"
+      (fun line start stop msg -> ((start, stop), msg, Some{start=line; stop=line}))
+  with Scanf.Scan_failure(_) ->
+  try
+    Scanf.sscanf
+      str
+      "Lines %d-%d, characters %d-%d:\n%[\000-\255]"
+      (fun start_line stop_line start stop msg -> ((start, stop),
+                                                   msg, Some{start=start_line;stop=stop_line}))
+  with Scanf.Scan_failure(_) ->
+    ((0, 0), str, None)
 
 let collect_formatters buf pps f =
   (* First flush all formatters. *)
@@ -365,10 +387,10 @@ let check_phrase phrase =
           None
         with exn ->
           (* The phrase contains errors. *)
-          let loc, msg = get_ocaml_error_message exn in
+          let loc, msg, line = get_ocaml_error_message exn in
           Toploop.toplevel_env := env;
           Btype.backtrack snap;
-          Some ([loc], msg)
+          Some ([loc], msg, [line])
 
 (* +-----------------------------------------------------------------+
    | Prompt                                                          |

src/lib/uTop.mli

@@ -254,6 +254,12 @@ type location = int * int
     (** Type of a string-location. It is composed of a start and stop
         offsets (in bytes). *)
 
+type lines = {
+  start: int;
+  stop:  int;
+}
+    (** Type for a range of lines in a buffer from start to stop. *)
+
 (** Result of a function processing a programx. *)
 type 'a result =
   | Value of 'a
@@ -310,12 +316,12 @@ val get_message : (Format.formatter -> 'a -> unit) -> 'a -> string
   (** [get_message printer x] applies [printer] on [x] and
       returns everything it prints as a string. *)
 
-val get_ocaml_error_message : exn -> location * string
+val get_ocaml_error_message : exn -> location * string * (lines option)
   (** [get_ocaml_error_message exn] returns the location and error
       message for the exception [exn] which must be an exception from
       the compiler. *)
 
-val check_phrase : Parsetree.toplevel_phrase -> (location list * string) option
+val check_phrase : Parsetree.toplevel_phrase -> (location list * string * lines option list) option
   (** [check_phrase phrase] checks that [phrase] can be executed
       without typing or compilation errors. It returns [None] if
       [phrase] is OK and an error message otherwise.

src/lib/uTop_main.ml

@@ -14,6 +14,7 @@ open Lwt_react
 open LTerm_dlist
 open LTerm_text
 open LTerm_geom
+open UTop
 open UTop_token
 open UTop_styles
 open UTop_private
@@ -77,7 +78,40 @@ let index_of_offset src ofs =
   in
   aux 0 0
 
-let convert_locs str locs = List.map (fun (a, b) -> (index_of_offset str a, index_of_offset str b)) locs
+let convert_loc str (a, b) = (index_of_offset str a, index_of_offset str b)
+
+let convert_locs str locs = List.map (fun (a, b) -> convert_loc str (a,b)) locs
+
+let get_line src line =
+  let rec aux line' ofs skipped =
+    if ofs >= String.length src then
+      ("", 0)
+    else if line' = line then
+      (String.sub src ofs (String.length src - ofs), skipped)
+    else
+      let ch, next_ofs = Zed_utf8.unsafe_extract_next src ofs in
+      if Zed_utf8.escaped_char ch = "\\n" then
+        aux (line' + 1) next_ofs (skipped + 1)
+      else
+        aux line' next_ofs (skipped + 1)
+  in
+  aux 1 0 0
+
+let convert_one_line str line ofs=
+  let selected, skipped = get_line str line in
+  index_of_offset selected ofs + skipped
+
+let convert_line str (start_ofs, end_ofs) lines =
+  (convert_one_line str lines.start start_ofs,
+  convert_one_line str lines.stop end_ofs)
+
+let convert_loc_line input locs lines =
+  List.map2 (fun loc line ->
+    match line with
+    | None ->
+      convert_loc input loc
+    | Some line ->
+      convert_line input loc line) locs lines
 
 (* +-----------------------------------------------------------------+
    | The read-line class                                             |
@@ -127,8 +161,8 @@ let parse_and_check input eos_is_error =
                  match UTop.check_phrase phrase with
                    | None ->
                        UTop.Value phrase
-                   | Some (locs, msg) ->
-                       UTop.Error (convert_locs input locs, msg)
+                   | Some (locs, msg, lines) ->
+                       UTop.Error (convert_loc_line input locs lines, msg)
                with Pparse.Error error ->
                  Pparse.report_error Format.str_formatter error;
                  UTop.Error ([], "Error: " ^ Format.flush_str_formatter () ^ "\n"))
@@ -1051,7 +1085,7 @@ module Emacs(M : sig end) = struct
     let typecheck phrase =
       match UTop.check_phrase phrase with
         | None -> None
-        | Some (locs, msg) -> Some (convert_locs input locs, msg)  (* FIXME *)
+        | Some (locs, msg, lines) -> Some (convert_loc_line input locs lines, msg)
     in
     match result with
       | UTop.Value phrases ->