Merge pull request #350 from chripell/master
Fix color highlight for errors.
This commit is contained in:
commit
c898602882
|
@ -103,6 +103,15 @@ let default_keywords = [
|
||||||
let keywords = ref (String_set.of_list default_keywords)
|
let keywords = ref (String_set.of_list default_keywords)
|
||||||
let add_keyword kwd = keywords := String_set.add kwd !keywords
|
let add_keyword kwd = keywords := String_set.add kwd !keywords
|
||||||
|
|
||||||
|
(* +-----------------------------------------------------------------+
|
||||||
|
| Span of Lines |
|
||||||
|
+-----------------------------------------------------------------+ *)
|
||||||
|
|
||||||
|
type lines = {
|
||||||
|
start: int;
|
||||||
|
stop: int;
|
||||||
|
}
|
||||||
|
|
||||||
(* +-----------------------------------------------------------------+
|
(* +-----------------------------------------------------------------+
|
||||||
| Error reporting |
|
| Error reporting |
|
||||||
+-----------------------------------------------------------------+ *)
|
+-----------------------------------------------------------------+ *)
|
||||||
|
@ -126,9 +135,22 @@ let get_ocaml_error_message exn =
|
||||||
Scanf.sscanf
|
Scanf.sscanf
|
||||||
str
|
str
|
||||||
"Characters %d-%d:\n%[\000-\255]"
|
"Characters %d-%d:\n%[\000-\255]"
|
||||||
(fun start stop msg -> ((start, stop), msg))
|
(fun start stop msg -> ((start, stop), msg, None))
|
||||||
with _ ->
|
with Scanf.Scan_failure(_) ->
|
||||||
((0, 0), str)
|
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 =
|
let collect_formatters buf pps f =
|
||||||
(* First flush all formatters. *)
|
(* First flush all formatters. *)
|
||||||
|
@ -365,10 +387,10 @@ let check_phrase phrase =
|
||||||
None
|
None
|
||||||
with exn ->
|
with exn ->
|
||||||
(* The phrase contains errors. *)
|
(* 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;
|
Toploop.toplevel_env := env;
|
||||||
Btype.backtrack snap;
|
Btype.backtrack snap;
|
||||||
Some ([loc], msg)
|
Some ([loc], msg, [line])
|
||||||
|
|
||||||
(* +-----------------------------------------------------------------+
|
(* +-----------------------------------------------------------------+
|
||||||
| Prompt |
|
| Prompt |
|
||||||
|
|
|
@ -254,6 +254,12 @@ type location = int * int
|
||||||
(** Type of a string-location. It is composed of a start and stop
|
(** Type of a string-location. It is composed of a start and stop
|
||||||
offsets (in bytes). *)
|
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. *)
|
(** Result of a function processing a programx. *)
|
||||||
type 'a result =
|
type 'a result =
|
||||||
| Value of 'a
|
| 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
|
(** [get_message printer x] applies [printer] on [x] and
|
||||||
returns everything it prints as a string. *)
|
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
|
(** [get_ocaml_error_message exn] returns the location and error
|
||||||
message for the exception [exn] which must be an exception from
|
message for the exception [exn] which must be an exception from
|
||||||
the compiler. *)
|
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
|
(** [check_phrase phrase] checks that [phrase] can be executed
|
||||||
without typing or compilation errors. It returns [None] if
|
without typing or compilation errors. It returns [None] if
|
||||||
[phrase] is OK and an error message otherwise.
|
[phrase] is OK and an error message otherwise.
|
||||||
|
|
|
@ -14,6 +14,7 @@ open Lwt_react
|
||||||
open LTerm_dlist
|
open LTerm_dlist
|
||||||
open LTerm_text
|
open LTerm_text
|
||||||
open LTerm_geom
|
open LTerm_geom
|
||||||
|
open UTop
|
||||||
open UTop_token
|
open UTop_token
|
||||||
open UTop_styles
|
open UTop_styles
|
||||||
open UTop_private
|
open UTop_private
|
||||||
|
@ -77,7 +78,40 @@ let index_of_offset src ofs =
|
||||||
in
|
in
|
||||||
aux 0 0
|
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 |
|
| The read-line class |
|
||||||
|
@ -127,8 +161,8 @@ let parse_and_check input eos_is_error =
|
||||||
match UTop.check_phrase phrase with
|
match UTop.check_phrase phrase with
|
||||||
| None ->
|
| None ->
|
||||||
UTop.Value phrase
|
UTop.Value phrase
|
||||||
| Some (locs, msg) ->
|
| Some (locs, msg, lines) ->
|
||||||
UTop.Error (convert_locs input locs, msg)
|
UTop.Error (convert_loc_line input locs lines, msg)
|
||||||
with Pparse.Error error ->
|
with Pparse.Error error ->
|
||||||
Pparse.report_error Format.str_formatter error;
|
Pparse.report_error Format.str_formatter error;
|
||||||
UTop.Error ([], "Error: " ^ Format.flush_str_formatter () ^ "\n"))
|
UTop.Error ([], "Error: " ^ Format.flush_str_formatter () ^ "\n"))
|
||||||
|
@ -1051,7 +1085,7 @@ module Emacs(M : sig end) = struct
|
||||||
let typecheck phrase =
|
let typecheck phrase =
|
||||||
match UTop.check_phrase phrase with
|
match UTop.check_phrase phrase with
|
||||||
| None -> None
|
| 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
|
in
|
||||||
match result with
|
match result with
|
||||||
| UTop.Value phrases ->
|
| UTop.Value phrases ->
|
||||||
|
|
Loading…
Reference in New Issue