handle warnings printed on stderr

Ignore-this: d07506d448326fd2675565215457dddc

darcs-hash:20120223140700-c41ad-6f4576a10ef6b3d3b586803e0de66e0e6d6be698
This commit is contained in:
Jeremie Dimino 2012-02-23 15:07:00 +01:00
parent a3367ec947
commit 5be22e37eb
3 changed files with 96 additions and 16 deletions

View File

@ -112,6 +112,65 @@ let get_ocaml_error_message exn =
with _ ->
((0, 0), str)
let collect_formatters buf pps f =
(* First flush all formatters. *)
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
(* Save all formatter functions. *)
let save = List.map (fun pp -> Format.pp_get_all_formatter_output_functions pp ()) pps in
let restore () =
List.iter2
(fun pp (out, flush, newline, spaces) ->
Format.pp_print_flush pp ();
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
pps save
in
(* Output functions. *)
let out str ofs len = Buffer.add_substring buf str ofs len in
let flush = ignore in
let newline () = Buffer.add_char buf '\n' in
let spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
(* Replace formatter functions. *)
let cols = (S.value size).cols in
List.iter
(fun pp ->
Format.pp_set_margin pp cols;
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
pps;
try
let x = f () in
restore ();
x
with exn ->
restore ();
raise exn
let discard_formatters pps f =
(* First flush all formatters. *)
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
(* Save all formatter functions. *)
let save = List.map (fun pp -> Format.pp_get_all_formatter_output_functions pp ()) pps in
let restore () =
List.iter2
(fun pp (out, flush, newline, spaces) ->
Format.pp_print_flush pp ();
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
pps save
in
(* Output functions. *)
let out str ofs len = () in
let flush = ignore in
let newline = ignore in
let spaces = ignore in
(* Replace formatter functions. *)
List.iter (fun pp -> Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces) pps;
try
let x = f () in
restore ();
x
with exn ->
restore ();
raise exn
(* +-----------------------------------------------------------------+
| Parsing |
+-----------------------------------------------------------------+ *)
@ -232,7 +291,7 @@ let check_phrase phrase =
} in
let check_phrase = Parsetree.Ptop_def [top_def] in
try
let _ = Toploop.execute_phrase false null check_phrase in
let _ = discard_formatters [Format.err_formatter] (fun () -> Toploop.execute_phrase false null check_phrase) in
(* The phrase is safe. *)
Toploop.toplevel_env := env;
Btype.backtrack snap;

View File

@ -216,6 +216,14 @@ val check_phrase : Parsetree.toplevel_phrase -> (location list * string) option
If the result is [None] it is guaranteed that
[Toploop.execute_phrase] won't raise any exception. *)
val collect_formatters : Buffer.t -> Format.formatter list -> (unit -> 'a) -> 'a
(** [collect_formatters buf pps f] executes [f] and redirect
everything it prints on [pps] to [buf]. *)
val discard_formatters : Format.formatter list -> (unit -> 'a) -> 'a
(** [discard_formatters pps f] executes [f], dropping everything it
prints on [pps]. *)
(**/**)
(* These variables are not used and deprecated: *)

View File

@ -73,21 +73,28 @@ let convert_locs str locs = List.map (fun (a, b) -> (index_of_offset str a, inde
+-----------------------------------------------------------------+ *)
let parse_and_check input eos_is_error =
match !UTop.parse_toplevel_phrase input eos_is_error with
| UTop.Error (locs, msg) ->
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
| UTop.Value phrase ->
match UTop.check_phrase phrase with
| None ->
UTop.Value phrase
| Some (locs, msg) ->
UTop.Error (convert_locs input locs, msg)
let buf = Buffer.create 32 in
let result =
UTop.collect_formatters buf [Format.err_formatter]
(fun () ->
match !UTop.parse_toplevel_phrase input eos_is_error with
| UTop.Error (locs, msg) ->
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
| UTop.Value phrase ->
match UTop.check_phrase phrase with
| None ->
UTop.Value phrase
| Some (locs, msg) ->
UTop.Error (convert_locs input locs, msg))
in
(result, Buffer.contents buf)
(* Read a phrase. If the result is a value, it is guaranteed to by a
valid phrase (i.e. typable and compilable). *)
valid phrase (i.e. typable and compilable). It also returns
warnings printed parsing. *)
class read_phrase ~term = object(self)
inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.engine ~history:(LTerm_history.contents UTop.history) () as super
inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.term term as super_term
inherit [Parsetree.toplevel_phrase UTop.result * string] LTerm_read_line.engine ~history:(LTerm_history.contents UTop.history) () as super
inherit [Parsetree.toplevel_phrase UTop.result * string] LTerm_read_line.term term as super_term
val mutable return_value = None
@ -135,7 +142,7 @@ class read_phrase ~term = object(self)
LTerm_text.stylise_parenthesis styled position styles.style_paren
else begin
match return_value with
| Some (UTop.Error (locs, _)) ->
| Some (UTop.Error (locs, _), _) ->
(* Highlight error locations. *)
List.iter
(fun (start, stop) ->
@ -301,7 +308,10 @@ let rec loop term =
let phrase_opt =
Lwt_main.run (
try_lwt
match_lwt read_phrase term with
lwt result, warnings = read_phrase term in
(* Print warnings before errors. *)
lwt () = Lwt_io.print warnings in
match result with
| UTop.Value phrase ->
return (Some phrase)
| UTop.Error (_, msg) ->
@ -527,9 +537,11 @@ module Emacs(M : sig end) = struct
let process_input add_to_history eos_is_error =
let input = read_data () in
match parse_and_check input eos_is_error with
let result, warnings = parse_and_check input eos_is_error in
match result with
| UTop.Value phrase -> begin
send "accept" "";
List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
if add_to_history then LTerm_history.add UTop.history input;
(* Add Lwt_main.run to toplevel evals. *)
let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in
@ -550,6 +562,7 @@ module Emacs(M : sig end) = struct
end
| UTop.Error (locs, msg) ->
send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
if add_to_history then LTerm_history.add UTop.history input;
List.iter (send "stderr") (split_at ~trim:true '\n' msg)