|
@@ -65,13 +65,15 @@ let resolve_file ctx f =
|
|
let error_printer file line = Printf.sprintf "%s:%d:" file line
|
|
let error_printer file line = Printf.sprintf "%s:%d:" file line
|
|
|
|
|
|
type error_context = {
|
|
type error_context = {
|
|
|
|
+ absolute_positions : bool;
|
|
mutable last_positions : pos IntMap.t;
|
|
mutable last_positions : pos IntMap.t;
|
|
mutable max_lines : int IntMap.t;
|
|
mutable max_lines : int IntMap.t;
|
|
mutable gutter : int IntMap.t;
|
|
mutable gutter : int IntMap.t;
|
|
mutable previous : (pos * MessageSeverity.t * int) option;
|
|
mutable previous : (pos * MessageSeverity.t * int) option;
|
|
}
|
|
}
|
|
|
|
|
|
-let create_error_context () = {
|
|
|
|
|
|
+let create_error_context absolute_positions = {
|
|
|
|
+ absolute_positions = absolute_positions;
|
|
last_positions = IntMap.empty;
|
|
last_positions = IntMap.empty;
|
|
max_lines = IntMap.empty;
|
|
max_lines = IntMap.empty;
|
|
gutter = IntMap.empty;
|
|
gutter = IntMap.empty;
|
|
@@ -97,7 +99,10 @@ let compiler_pretty_message_string com ectx cm =
|
|
let f = Common.find_file com f in
|
|
let f = Common.find_file com f in
|
|
let l1, p1, l2, p2 = Lexer.get_pos_coords cm.cm_pos in
|
|
let l1, p1, l2, p2 = Lexer.get_pos_coords cm.cm_pos in
|
|
let lines = resolve_source f l1 p1 l2 p2 in
|
|
let lines = resolve_source f l1 p1 l2 p2 in
|
|
- let epos = Lexer.get_error_pos error_printer cm.cm_pos in
|
|
|
|
|
|
+ let epos =
|
|
|
|
+ if ectx.absolute_positions then TPrinting.Printer.s_pos cm.cm_pos
|
|
|
|
+ else Lexer.get_error_pos error_printer cm.cm_pos
|
|
|
|
+ in
|
|
(l1, p1, l2, p2, epos, lines)
|
|
(l1, p1, l2, p2, epos, lines)
|
|
end with Not_found | Sys_error _ ->
|
|
end with Not_found | Sys_error _ ->
|
|
(1, 1, 1, 1, cm.cm_pos.pfile, [])
|
|
(1, 1, 1, 1, cm.cm_pos.pfile, [])
|
|
@@ -243,7 +248,7 @@ let compiler_pretty_message_string com ectx cm =
|
|
)
|
|
)
|
|
end
|
|
end
|
|
|
|
|
|
-let compiler_message_string cm =
|
|
|
|
|
|
+let compiler_message_string ectx cm =
|
|
let str = match cm.cm_severity with
|
|
let str = match cm.cm_severity with
|
|
| MessageSeverity.Warning -> "Warning : " ^ cm.cm_message
|
|
| MessageSeverity.Warning -> "Warning : " ^ cm.cm_message
|
|
| Information | Error | Hint -> cm.cm_message
|
|
| Information | Error | Hint -> cm.cm_message
|
|
@@ -252,7 +257,10 @@ let compiler_message_string cm =
|
|
if cm.cm_pos = null_pos then
|
|
if cm.cm_pos = null_pos then
|
|
Some str
|
|
Some str
|
|
else begin
|
|
else begin
|
|
- let epos = Lexer.get_error_pos error_printer cm.cm_pos in
|
|
|
|
|
|
+ let epos =
|
|
|
|
+ if ectx.absolute_positions then TPrinting.Printer.s_pos cm.cm_pos
|
|
|
|
+ else Lexer.get_error_pos error_printer cm.cm_pos
|
|
|
|
+ in
|
|
let str =
|
|
let str =
|
|
let lines =
|
|
let lines =
|
|
match (ExtString.String.nsplit str "\n") with
|
|
match (ExtString.String.nsplit str "\n") with
|
|
@@ -264,7 +272,7 @@ let compiler_message_string cm =
|
|
Some (Printf.sprintf "%s : %s" epos str)
|
|
Some (Printf.sprintf "%s : %s" epos str)
|
|
end
|
|
end
|
|
|
|
|
|
-let compiler_indented_message_string cm =
|
|
|
|
|
|
+let compiler_indented_message_string ectx cm =
|
|
match cm.cm_message with
|
|
match cm.cm_message with
|
|
(* Filter some messages that don't add much when using this message renderer *)
|
|
(* Filter some messages that don't add much when using this message renderer *)
|
|
| "End of overload failure reasons" -> None
|
|
| "End of overload failure reasons" -> None
|
|
@@ -278,7 +286,10 @@ let compiler_indented_message_string cm =
|
|
if cm.cm_pos = null_pos then
|
|
if cm.cm_pos = null_pos then
|
|
Some str
|
|
Some str
|
|
else begin
|
|
else begin
|
|
- let epos = Lexer.get_error_pos error_printer cm.cm_pos in
|
|
|
|
|
|
+ let epos =
|
|
|
|
+ if ectx.absolute_positions then TPrinting.Printer.s_pos cm.cm_pos
|
|
|
|
+ else Lexer.get_error_pos error_printer cm.cm_pos
|
|
|
|
+ in
|
|
let lines =
|
|
let lines =
|
|
match (ExtString.String.nsplit str "\n") with
|
|
match (ExtString.String.nsplit str "\n") with
|
|
| first :: rest -> (cm.cm_depth, first) :: List.map (fun msg -> (cm.cm_depth+1, msg)) rest
|
|
| first :: rest -> (cm.cm_depth, first) :: List.map (fun msg -> (cm.cm_depth+1, msg)) rest
|
|
@@ -299,10 +310,10 @@ let get_max_line max_lines messages =
|
|
|
|
|
|
exception ConfigError of string
|
|
exception ConfigError of string
|
|
|
|
|
|
-let get_formatter com ectx def default =
|
|
|
|
|
|
+let get_formatter com def default =
|
|
let format_mode = Define.defined_value_safe ~default com.defines def in
|
|
let format_mode = Define.defined_value_safe ~default com.defines def in
|
|
match format_mode with
|
|
match format_mode with
|
|
- | "pretty" -> compiler_pretty_message_string com ectx
|
|
|
|
|
|
+ | "pretty" -> compiler_pretty_message_string com
|
|
| "indent" -> compiler_indented_message_string
|
|
| "indent" -> compiler_indented_message_string
|
|
| "classic" -> compiler_message_string
|
|
| "classic" -> compiler_message_string
|
|
| m -> begin
|
|
| m -> begin
|
|
@@ -318,11 +329,12 @@ let print_error (err : Error.error) =
|
|
!ret
|
|
!ret
|
|
|
|
|
|
let format_messages com messages =
|
|
let format_messages com messages =
|
|
- let ectx = create_error_context () in
|
|
|
|
|
|
+ let absolute_positions = Define.defined com.defines Define.MessageAbsolutePositions in
|
|
|
|
+ let ectx = create_error_context absolute_positions in
|
|
ectx.max_lines <- get_max_line ectx.max_lines messages;
|
|
ectx.max_lines <- get_max_line ectx.max_lines messages;
|
|
- let message_formatter = get_formatter com ectx Define.MessageReporting "classic" in
|
|
|
|
|
|
+ let message_formatter = get_formatter com Define.MessageReporting "classic" in
|
|
let lines = List.rev (
|
|
let lines = List.rev (
|
|
- List.fold_left (fun lines cm -> match (message_formatter cm) with
|
|
|
|
|
|
+ List.fold_left (fun lines cm -> match (message_formatter ectx cm) with
|
|
| None -> lines
|
|
| None -> lines
|
|
| Some str -> str :: lines
|
|
| Some str -> str :: lines
|
|
) [] messages
|
|
) [] messages
|
|
@@ -330,18 +342,19 @@ let format_messages com messages =
|
|
ExtLib.String.join "\n" lines
|
|
ExtLib.String.join "\n" lines
|
|
|
|
|
|
let display_messages ctx on_message = begin
|
|
let display_messages ctx on_message = begin
|
|
- let ectx = create_error_context () in
|
|
|
|
|
|
+ let absolute_positions = Define.defined ctx.com.defines Define.MessageAbsolutePositions in
|
|
|
|
+ let ectx = create_error_context absolute_positions in
|
|
ectx.max_lines <- get_max_line ectx.max_lines ctx.messages;
|
|
ectx.max_lines <- get_max_line ectx.max_lines ctx.messages;
|
|
|
|
|
|
- let get_formatter _ _ def default =
|
|
|
|
- try get_formatter ctx.com ectx def default
|
|
|
|
|
|
+ let get_formatter _ def default =
|
|
|
|
+ try get_formatter ctx.com def default
|
|
with | ConfigError s ->
|
|
with | ConfigError s ->
|
|
error ctx s null_pos;
|
|
error ctx s null_pos;
|
|
compiler_message_string
|
|
compiler_message_string
|
|
in
|
|
in
|
|
|
|
|
|
- let message_formatter = get_formatter ctx.com ectx Define.MessageReporting "classic" in
|
|
|
|
- let log_formatter = get_formatter ctx.com ectx Define.MessageLogFormat "indent" in
|
|
|
|
|
|
+ let message_formatter = get_formatter ctx.com Define.MessageReporting "classic" in
|
|
|
|
+ let log_formatter = get_formatter ctx.com Define.MessageLogFormat "indent" in
|
|
|
|
|
|
let log_messages = ref (Define.defined ctx.com.defines Define.MessageLogFile) in
|
|
let log_messages = ref (Define.defined ctx.com.defines Define.MessageLogFile) in
|
|
let log_message = ref None in
|
|
let log_message = ref None in
|
|
@@ -358,7 +371,7 @@ let display_messages ctx on_message = begin
|
|
in
|
|
in
|
|
|
|
|
|
log_message := (Some (fun msg ->
|
|
log_message := (Some (fun msg ->
|
|
- match (log_formatter msg) with
|
|
|
|
|
|
+ match (log_formatter ectx msg) with
|
|
| None -> ()
|
|
| None -> ()
|
|
| Some str -> Rbuffer.add_string buf (str ^ "\n")));
|
|
| Some str -> Rbuffer.add_string buf (str ^ "\n")));
|
|
|
|
|
|
@@ -378,7 +391,7 @@ let display_messages ctx on_message = begin
|
|
List.iter (fun cm ->
|
|
List.iter (fun cm ->
|
|
if !log_messages then (Option.get !log_message) cm;
|
|
if !log_messages then (Option.get !log_message) cm;
|
|
|
|
|
|
- match (message_formatter cm) with
|
|
|
|
|
|
+ match (message_formatter ectx cm) with
|
|
| None -> ()
|
|
| None -> ()
|
|
| Some str -> on_message cm.cm_severity str
|
|
| Some str -> on_message cm.cm_severity str
|
|
) (List.rev ctx.messages);
|
|
) (List.rev ctx.messages);
|