Merge pull request #350 from chripell/master

Fix color highlight for errors.

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 ->