diff options
43 files changed, 390 insertions, 270 deletions
diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 40f7dafbd..34283875c 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -140,3 +140,10 @@ let report_error ppf = function | Assembler_error file -> fprintf ppf "Assembler error, input left in file %a" Location.print_filename file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index 140791f22..968e1de74 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -69,3 +69,10 @@ let report_error ppf = function fprintf ppf "Cannot find file %s" name | Archiver_error name -> fprintf ppf "Error while creating the library %s" name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index f6a85a94c..30bb13f63 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -390,3 +390,10 @@ let report_error ppf = function Location.print_filename filename name Location.print_filename filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 1a4fe9027..a8fcfe789 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -204,3 +204,10 @@ let report_error ppf = function fprintf ppf "Error while assembling %s" file | Linking_error -> fprintf ppf "Error during partial linking" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 280b13127..48d6be7d4 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -245,3 +245,10 @@ let report_error ppf = function fprintf ppf "%a@ contains the description for unit\ @ %s when %s was expected" Location.print_filename filename name modname + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex f2ed6fd49..a5355b2f5 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 05cd295f4..2ebbe5111 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex bb4ebc652..ac43afab3 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index fdcb0d882..c63cf80ec 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -117,3 +117,10 @@ let report_error ppf = function | Not_an_object_file name -> fprintf ppf "The file %a is not a bytecode object file" Location.print_filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index b1660e9a3..75db3533c 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -622,3 +622,10 @@ let report_error ppf = function | Not_compatible_32 -> fprintf ppf "Generated bytecode executable cannot be run\ \ on a 32-bit platform" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index f548c771a..8ba2f5321 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -276,3 +276,10 @@ let report_error ppf = function Location.print_filename file name id | File_not_found file -> fprintf ppf "File %s not found" file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 412c1ab09..9c94c9046 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -372,3 +372,10 @@ let report_error ppf = function fprintf ppf "Cannot find or execute the runtime system %s" s | Uninitialized_global s -> fprintf ppf "The value of the global `%s' is not yet computed" s + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 0b3bd45ef..b22c0adaf 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -826,3 +826,12 @@ let report_error ppf = function | Tags (lab1, lab2) -> fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" lab1 lab2 "Change one of them." + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 86f0bf4fa..092eeba25 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -1120,3 +1120,12 @@ let report_error ppf = function "Ancestor names can only be used to select inherited methods" | Unknown_builtin_primitive prim_name -> fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 0c26ecd07..672449f1d 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -810,3 +810,12 @@ let report_error ppf = function "@[Cannot safely evaluate the definition@ \ of the recursively-defined module %a@]" Printtyp.ident id + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff --git a/driver/errors.ml b/driver/errors.ml index 14a1a23cb..bda1a30ac 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -10,72 +10,7 @@ (* *) (***********************************************************************) -(* WARNING: if you change something in this file, you must look at - opterrors.ml and ocamldoc/odoc_analyse.ml - to see if you need to make the same changes there. -*) +(* This module should be removed. We keep it for now, to avoid + breaking external tools depending on it. *) -open Format - -(* Report an error *) - -let report_error ppf exn = - let report ppf = function - | Lexer.Error(err, loc) -> - Location.print_error ppf loc; - Lexer.report_error ppf err - | Syntaxerr.Error err -> - Syntaxerr.report_error ppf err - | Pparse.Error err -> - Pparse.report_error ppf err - | Env.Error err -> - Location.print_error_cur_file ppf; - Env.report_error ppf err - | Cmi_format.Error err -> - Location.print_error_cur_file ppf; - Cmi_format.report_error ppf err - | Ctype.Tags(l, l') -> - Location.print_error_cur_file ppf; - fprintf ppf - "In this program,@ variant constructors@ `%s and `%s@ \ - have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, env, err) -> - Location.print_error ppf loc; Typecore.report_error env ppf err - | Typetexp.Error(loc, env, err) -> - Location.print_error ppf loc; Typetexp.report_error env ppf err - | Typedecl.Error(loc, err) -> - Location.print_error ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, env, err) -> - Location.print_error ppf loc; Typeclass.report_error env ppf err - | Includemod.Error err -> - Location.print_error_cur_file ppf; - Includemod.report_error ppf err - | Typemod.Error(loc, env, err) -> - Location.print_error ppf loc; Typemod.report_error env ppf err - | Translcore.Error(loc, err) -> - Location.print_error ppf loc; Translcore.report_error ppf err - | Translclass.Error(loc, err) -> - Location.print_error ppf loc; Translclass.report_error ppf err - | Translmod.Error(loc, err) -> - Location.print_error ppf loc; Translmod.report_error ppf err - | Symtable.Error code -> - Location.print_error_cur_file ppf; - Symtable.report_error ppf code - | Bytelink.Error code -> - Location.print_error_cur_file ppf; - Bytelink.report_error ppf code - | Bytelibrarian.Error code -> - Location.print_error_cur_file ppf; - Bytelibrarian.report_error ppf code - | Bytepackager.Error code -> - Location.print_error_cur_file ppf; - Bytepackager.report_error ppf code - | Sys_error msg -> - Location.print_error_cur_file ppf; - fprintf ppf "I/O error: %s" msg - | Warnings.Errors (n) -> - Location.print_error_cur_file ppf; - fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n - | x -> fprintf ppf "@]"; raise x in - - fprintf ppf "@[%a@]@." report exn +let report_error = Location.report_exception diff --git a/driver/main.ml b/driver/main.ml index 4ab251c7f..d038af75a 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -184,7 +184,7 @@ let main () = end; exit 0 with x -> - Errors.report_error ppf x; + Location.report_exception ppf x; exit 2 let _ = main () diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 56660cdb1..bda1a30ac 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -10,74 +10,7 @@ (* *) (***********************************************************************) -(* WARNING: if you change something in this file, you must look at - errors.ml to see if you need to make the same changes there. -*) +(* This module should be removed. We keep it for now, to avoid + breaking external tools depending on it. *) -open Format - -(* Report an error *) - -let report_error ppf exn = - let report ppf = function - | Lexer.Error(err, l) -> - Location.print_error ppf l; - Lexer.report_error ppf err - | Syntaxerr.Error err -> - Syntaxerr.report_error ppf err - | Pparse.Error err -> - Pparse.report_error ppf err - | Env.Error err -> - Location.print_error_cur_file ppf; - Env.report_error ppf err - | Cmi_format.Error err -> - Location.print_error_cur_file ppf; - Cmi_format.report_error ppf err - | Ctype.Tags(l, l') -> - Location.print_error_cur_file ppf; - fprintf ppf - "In this program,@ variant constructors@ `%s and `%s@ \ - have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, env, err) -> - Location.print_error ppf loc; Typecore.report_error env ppf err - | Typetexp.Error(loc, env, err) -> - Location.print_error ppf loc; Typetexp.report_error env ppf err - | Typedecl.Error(loc, err) -> - Location.print_error ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, env, err) -> - Location.print_error ppf loc; Typeclass.report_error env ppf err - | Includemod.Error err -> - Location.print_error_cur_file ppf; - Includemod.report_error ppf err - | Typemod.Error(loc, env, err) -> - Location.print_error ppf loc; Typemod.report_error env ppf err - | Translcore.Error(loc, err) -> - Location.print_error ppf loc; Translcore.report_error ppf err - | Translclass.Error(loc, err) -> - Location.print_error ppf loc; Translclass.report_error ppf err - | Translmod.Error(loc, err) -> - Location.print_error ppf loc; Translmod.report_error ppf err - | Compilenv.Error code -> - Location.print_error_cur_file ppf; - Compilenv.report_error ppf code - | Asmgen.Error code -> - Location.print_error_cur_file ppf; - Asmgen.report_error ppf code - | Asmlink.Error code -> - Location.print_error_cur_file ppf; - Asmlink.report_error ppf code - | Asmlibrarian.Error code -> - Location.print_error_cur_file ppf; - Asmlibrarian.report_error ppf code - | Asmpackager.Error code -> - Location.print_error_cur_file ppf; - Asmpackager.report_error ppf code - | Sys_error msg -> - Location.print_error_cur_file ppf; - fprintf ppf "I/O error: %s" msg - | Warnings.Errors (n) -> - Location.print_error_cur_file ppf; - fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n - | x -> fprintf ppf "@]"; raise x in - - fprintf ppf "@[%a@]@." report exn +let report_error = Location.report_exception diff --git a/driver/optmain.ml b/driver/optmain.ml index 45bdec244..9f973f2b1 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -201,7 +201,7 @@ let main () = end; exit 0 with x -> - Opterrors.report_error ppf x; - exit 2 + Location.report_exception ppf x; + exit 2 let _ = main () diff --git a/driver/pparse.ml b/driver/pparse.ml index 15a1bd397..7f9974da7 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -59,7 +59,8 @@ let apply_rewriter magic fn_in ppx = Misc.remove_file fn_out; raise (Error (CannotRun comm)); end; - if not (Sys.file_exists fn_out) then raise (Error (WrongMagic comm)); + if not (Sys.file_exists fn_out) then + raise (Error (WrongMagic comm)); (* check magic before passing to the next ppx *) let ic = open_in_bin fn_out in let buffer = @@ -143,6 +144,12 @@ let report_error ppf = function fprintf ppf "External preprocessor does not produce a valid file@.\ Command line: %s@." cmd +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) let parse_all parse_fun magic ppf sourcefile = Location.input_name := sourcefile; diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 19621cb5e..98f73617d 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -100,60 +100,16 @@ module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever) (** The module used to analyse the parse tree and typed tree of an interface file.*) module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever) -(** Handle an error. This is a partial copy of the compiler - driver/error.ml file. We do this because there are - some differences between the possibly raised exceptions - in the bytecode (error.ml) and opt (opterros.ml) compilers - and we don't want to take care of this. Besises, these - differences only concern code generation (i believe).*) +(** Handle an error. *) + let process_error exn = - let report ppf = function - | Lexer.Error(err, loc) -> - Location.print_error ppf loc; - Lexer.report_error ppf err - | Syntaxerr.Error err -> - Syntaxerr.report_error ppf err - | Env.Error err -> - Location.print_error_cur_file ppf; - Env.report_error ppf err - | Cmi_format.Error err -> - Location.print_error_cur_file ppf; - Cmi_format.report_error ppf err - | Ctype.Tags(l, l') -> - Location.print_error_cur_file ppf; - fprintf ppf - "In this program,@ variant constructors@ `%s and `%s@ \ - have the same hash value." l l' - | Typecore.Error(loc, env, err) -> - Location.print_error ppf loc; Typecore.report_error env ppf err - | Typetexp.Error(loc, env, err) -> - Location.print_error ppf loc; Typetexp.report_error env ppf err - | Typedecl.Error(loc, err) -> - Location.print_error ppf loc; Typedecl.report_error ppf err - | Includemod.Error err -> - Location.print_error_cur_file ppf; - Includemod.report_error ppf err - | Typemod.Error(loc, env, err) -> - Location.print_error ppf loc; Typemod.report_error env ppf err - | Translcore.Error(loc, err) -> - Location.print_error ppf loc; Translcore.report_error ppf err - | Sys_error msg -> - Location.print_error_cur_file ppf; - fprintf ppf "I/O error: %s" msg - | Typeclass.Error(loc, env, err) -> - Location.print_error ppf loc; Typeclass.report_error env ppf err - | Translclass.Error(loc, err) -> - Location.print_error ppf loc; Translclass.report_error ppf err - | Warnings.Errors (n) -> - Location.print_error_cur_file ppf; - fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n - | x -> - fprintf ppf "@]"; - fprintf ppf - "Compilation error(%s). Use the OCaml compiler to get more details." - (Printexc.to_string x) - in - Format.fprintf Format.err_formatter "@[%a@]@." report exn + match Location.error_of_exn exn with + | Some err -> + fprintf Format.err_formatter "@[%a@]@." Location.report_error err + | None -> + fprintf Format.err_formatter + "Compilation error(%s). Use the OCaml compiler to get more details.@." + (Printexc.to_string exn) (** Process the given file, according to its extension. Return the Module.t created, if any.*) let process_file ppf sourcefile = diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 0c98ffc34..b067b2aa3 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -31,6 +31,7 @@ exception Error of error * Location.t open Format val report_error: formatter -> error -> unit + (* Deprecated. Use Location.{error_of_exn, report_error}. *) val in_comment : unit -> bool;; val in_string : unit -> bool;; diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 8b34b2483..8aed03b2f 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -242,7 +242,15 @@ let report_error ppf = function | Literal_overflow ty -> fprintf ppf "Integer literal exceeds the range of representable \ integers of type %s" ty -;; + +let () = + Location.register_error_of_exn + (function + | Error (err, loc) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) } diff --git a/parsing/location.ml b/parsing/location.ml index d3f89f440..132021f5b 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -74,7 +74,7 @@ let num_loc_lines = ref 0 (* number of lines already printed after input *) (* Highlight the locations using standout mode. *) -let highlight_terminfo ppf num_lines lb loc1 loc2 = +let highlight_terminfo ppf num_lines lb locs = Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) let pos0 = -lb.lex_abs_pos in @@ -94,9 +94,9 @@ let highlight_terminfo ppf num_lines lb loc1 loc2 = print_string "# "; for pos = 0 to lb.lex_buffer_len - pos0 - 1 do if !bol then (print_string " "; bol := false); - if pos = loc1.loc_start.pos_cnum || pos = loc2.loc_start.pos_cnum then + if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then Terminfo.standout true; - if pos = loc1.loc_end.pos_cnum || pos = loc2.loc_end.pos_cnum then + if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then Terminfo.standout false; let c = lb.lex_buffer.[pos + pos0] in print_char c; @@ -176,10 +176,10 @@ let highlight_dumb ppf lb loc = (* Highlight the location using one of the supported modes. *) -let rec highlight_locations ppf loc1 loc2 = +let rec highlight_locations ppf locs = match !status with Terminfo.Uninitialised -> - status := Terminfo.setup stdout; highlight_locations ppf loc1 loc2 + status := Terminfo.setup stdout; highlight_locations ppf locs | Terminfo.Bad_term -> begin match !input_lexbuf with None -> false @@ -187,6 +187,7 @@ let rec highlight_locations ppf loc1 loc2 = let norepeat = try Sys.getenv "TERM" = "norepeat" with Not_found -> false in if norepeat then false else + let loc1 = List.hd locs in try highlight_dumb ppf lb loc1; true with Exit -> false end @@ -194,7 +195,7 @@ let rec highlight_locations ppf loc1 loc2 = begin match !input_lexbuf with None -> false | Some lb -> - try highlight_terminfo ppf num_lines lb loc1 loc2; true + try highlight_terminfo ppf num_lines lb locs; true with Exit -> false end @@ -237,7 +238,7 @@ let print_loc ppf loc = let (file, line, startchar) = get_pos_info loc.loc_start in let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in if file = "//toplevel//" then begin - if highlight_locations ppf loc none then () else + if highlight_locations ppf [loc] then () else fprintf ppf "Characters %i-%i" loc.loc_start.pos_cnum loc.loc_end.pos_cnum end else begin @@ -249,7 +250,7 @@ let print_loc ppf loc = let print ppf loc = if loc.loc_start.pos_fname = "//toplevel//" - && highlight_locations ppf loc none then () + && highlight_locations ppf [loc] then () else fprintf ppf "%a%s@." print_loc loc msg_colon ;; @@ -286,3 +287,82 @@ type 'a loc = { let mkloc txt loc = { txt ; loc } let mknoloc txt = mkloc txt none + + +type error = + { + loc: t; + msg: string; + sub: error list; + if_highlight: string; (* alternative message if locations are highlighted *) + } + +let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") = + Printf.ksprintf (fun msg -> {loc; msg; sub; if_highlight}) + +let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg = + {loc; msg; sub; if_highlight} + +let error_of_exn : (exn -> error option) list ref = ref [] + +let register_error_of_exn f = error_of_exn := f :: !error_of_exn + +let error_of_exn exn = + let rec loop = function + | [] -> None + | f :: rest -> + match f exn with + | Some _ as r -> r + | None -> loop rest + in + loop !error_of_exn + +let rec report_error ppf ({loc; msg; sub; if_highlight} as err) = + let highlighted = + if if_highlight <> "" then + let rec collect_locs locs {loc; sub; if_highlight; _} = + List.fold_left collect_locs (loc :: locs) sub + in + let locs = collect_locs [] err in + highlight_locations ppf locs + else + false + in + if highlighted then + Format.pp_print_string ppf if_highlight + else begin + print ppf loc; + Format.pp_print_string ppf msg; + List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub + end + +let error_of_printer loc print x = + let buf = Buffer.create 64 in + let ppf = Format.formatter_of_buffer buf in + pp_print_string ppf "Error: "; + print ppf x; + pp_print_flush ppf (); + let msg = Buffer.contents buf in + errorf ~loc "%s" msg + +let error_of_printer_file print x = + error_of_printer (in_file !input_name) print x + +let () = + register_error_of_exn + (function + | Sys_error msg -> + Some (errorf ~loc:(in_file !input_name) "Error: I/O error: %s" msg) + | Warnings.Errors n -> + Some + (errorf ~loc:(in_file !input_name) + "Error: Some fatal warnings were triggered (%d occurrences)" n) + | _ -> + None + ) + + +let report_exception ppf exn = + match error_of_exn exn with + | Some err -> fprintf ppf "@[%a@]@." report_error err + | None -> raise exn diff --git a/parsing/location.mli b/parsing/location.mli index bae909020..e6df9d1f6 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -56,7 +56,7 @@ val prerr_warning: t -> Warnings.t -> unit val echo_eof: unit -> unit val reset: unit -> unit -val highlight_locations: formatter -> t -> t -> bool +val highlight_locations: formatter -> t list -> bool type 'a loc = { txt : 'a; @@ -75,3 +75,37 @@ val show_filename: string -> string val absname: bool ref + + +(* Support for located errors *) + +type error = + { + loc: t; + msg: string; + sub: error list; + if_highlight: string; (* alternative message if locations are highlighted *) + } + +val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error + +val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string -> ('a, unit, string, error) format4 -> 'a + +val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error + +val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error + +val error_of_exn: exn -> error option + +val register_error_of_exn: (exn -> error option) -> unit + (* Each compiler module which defines a custom type of exception + which can surface as a user-visible error should register + a "printer" for this exception using [register_error_of_exn]. + The result of the printer is an [error] value containing + a location, a message, and optionally sub-messages (each of them + being located as well). *) + +val report_error: formatter -> error -> unit + +val report_exception: formatter -> exn -> unit + (* Reraise the exception if it is unknown. *) diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index b19a382d4..13212eecd 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -12,8 +12,6 @@ (* Auxiliary type for reporting syntax errors *) -open Format - type error = Unclosed of Location.t * string * Location.t * string | Expecting of Location.t * string @@ -22,44 +20,48 @@ type error = | Variable_in_scope of Location.t * string | Other of Location.t - - exception Error of error exception Escape_error -let report_error ppf = function +let prepare_error = function | Unclosed(opening_loc, opening, closing_loc, closing) -> - if !Location.input_name = "//toplevel//" - && Location.highlight_locations ppf opening_loc closing_loc - then fprintf ppf "Syntax error: '%s' expected, \ - the highlighted '%s' might be unmatched" closing opening - else begin - fprintf ppf "%aSyntax error: '%s' expected@." - Location.print_error closing_loc closing; - fprintf ppf "%aThis '%s' might be unmatched" - Location.print_error opening_loc opening - end + Location.errorf ~loc:closing_loc + ~sub:[ + Location.error ~loc:opening_loc + (Printf.sprintf "Error: This '%s' might be unmatched" opening) + ] + ~if_highlight: + (Printf.sprintf "Syntax error: '%s' expected, \ + the highlighted '%s' might be unmatched" + closing opening) + "Error: Syntax error: '%s' expected" closing + | Expecting (loc, nonterm) -> - fprintf ppf - "%a@[Syntax error: %s expected.@]" - Location.print_error loc nonterm + Location.errorf ~loc "Error: Syntax error: %s expected." nonterm | Not_expecting (loc, nonterm) -> - fprintf ppf - "%a@[Syntax error: %s not expected.@]" - Location.print_error loc nonterm + Location.errorf ~loc "Error: Syntax error: %s not expected." nonterm | Applicative_path loc -> - fprintf ppf - "%aSyntax error: applicative paths of the form F(X).t \ + Location.errorf ~loc + "Error: Syntax error: applicative paths of the form F(X).t \ are not supported when the option -no-app-func is set." - Location.print_error loc | Variable_in_scope (loc, var) -> - fprintf ppf - "%a@[In this scoped type, variable '%s@ \ - is reserved for the local type %s.@]" - Location.print_error loc var var + Location.errorf ~loc + "Error: In this scoped type, variable '%s@ \ + is reserved for the local type %s." + var var | Other loc -> - fprintf ppf "%aSyntax error" Location.print_error loc + Location.error ~loc "Error: Syntax error" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (prepare_error err) + | _ -> None + ) + +let report_error ppf err = + Location.report_error ppf (prepare_error err) let location_of_error = function | Unclosed(l,_,_,_) diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 0bacb0f95..1aec26ed5 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -26,5 +26,6 @@ exception Error of error exception Escape_error val report_error: formatter -> error -> unit + (* Deprecated. Use Location.{error_of_exn, report_error}. *) val location_of_error: error -> Location.t diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index 2b0b9513c..735a5f97b 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -208,20 +208,14 @@ let print_raw_dependencies source_file deps = let report_err source_file exn = error_occurred := true; match exn with - | Lexer.Error(err, range) -> - Format.fprintf Format.err_formatter "@[%a%a@]@." - Location.print_error range Lexer.report_error err - | Syntaxerr.Error err -> - Format.fprintf Format.err_formatter "@[%a@]@." - Syntaxerr.report_error err | Sys_error msg -> Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg - | Pparse.Error err -> - Format.fprintf Format.err_formatter - "@[Preprocessing error on file %s@]@.@[%a@]@." - source_file - Pparse.report_error err - | x -> raise x + | x -> + match Location.error_of_exn x with + | Some err -> + Format.fprintf Format.err_formatter "@[%a@]@." + Location.report_error err + | None -> raise x let read_parse_and_extract parse_function extract_function magic source_file = Depend.free_structure_names := Depend.StringSet.empty; diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 77c50168a..1fde3fe49 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -499,20 +499,11 @@ let main () = " Print version number and exit"; ] process_anon_file usage; exit 0 - with x -> - let report_error ppf = function - | Lexer.Error(err, range) -> - fprintf ppf "@[%a%a@]@." - Location.print_error range Lexer.report_error err - | Syntaxerr.Error err -> - fprintf ppf "@[%a@]@." - Syntaxerr.report_error err - | Profiler msg -> - fprintf ppf "@[%s@]@." msg - | Sys_error msg -> - fprintf ppf "@[I/O error:@ %s@]@." msg - | x -> raise x in - report_error Format.err_formatter x; - exit 2 + with + | Profiler msg -> + fprintf Format.err_formatter "@[%s@]@." msg; + exit 2 + | exn -> + Location.report_exception Format.err_formatter exn let _ = main () diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 770ce481c..5bac89781 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -325,7 +325,7 @@ let use_file ppf name = with | Exit -> false | Sys.Break -> fprintf ppf "Interrupted.@."; false - | x -> Opterrors.report_error ppf x; false) in + | x -> Location.report_exception ppf x; false) in if must_close then close_in ic; success with Not_found -> fprintf ppf "Cannot find file %s.@." name; false @@ -439,7 +439,7 @@ let loop ppf = | End_of_file -> exit 0 | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap | PPerror -> () - | x -> Opterrors.report_error ppf x; Btype.backtrack snap + | x -> Location.report_exception ppf x; Btype.backtrack snap done (* Execute a script *) diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 43141e8c0..3e15c1988 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -26,7 +26,7 @@ let prepare ppf = !Opttoploop.toplevel_startup_hook (); res with x -> - try Opterrors.report_error ppf x; false + try Location.report_exception ppf x; false with x -> Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); false diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 8b8c659bd..78c6eca32 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -349,7 +349,7 @@ let use_file ppf wrap_mod name = with | Exit -> false | Sys.Break -> fprintf ppf "Interrupted.@."; false - | x -> Errors.report_error ppf x; false) in + | x -> Location.report_exception ppf x; false) in if must_close then close_in ic; success with Not_found -> fprintf ppf "Cannot find file %s.@." name; false @@ -468,7 +468,7 @@ let loop ppf = | End_of_file -> exit 0 | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap | PPerror -> () - | x -> Errors.report_error ppf x; Btype.backtrack snap + | x -> Location.report_exception ppf x; Btype.backtrack snap done (* Execute a script. If [name] is "", read the script from stdin. *) diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index 8fbf9ddc5..3091ca0d2 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -26,7 +26,7 @@ let prepare ppf = !Toploop.toplevel_startup_hook (); res with x -> - try Errors.report_error ppf x; false + try Location.report_exception ppf x; false with x -> Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); false diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml index d40b1977d..e5a8399fa 100644 --- a/typing/cmi_format.ml +++ b/typing/cmi_format.ml @@ -91,3 +91,10 @@ let report_error ppf = function | Corrupted_interface filename -> fprintf ppf "Corrupted compiled interface@ %a" Location.print_filename filename + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/typing/ctype.ml b/typing/ctype.ml index 8bd28e1c1..4d4d84432 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -84,6 +84,19 @@ exception Unify of (type_expr * type_expr) list exception Tags of label * label +let () = + Location.register_error_of_exn + (function + | Tags (l, l') -> + Some + Location. + (errorf ~loc:(in_file !input_name) + "In this program,@ variant constructors@ `%s and `%s@ \ + have the same hash value.@ Change one of them." l l' + ) + | _ -> None + ) + exception Subtype of (type_expr * type_expr) list * (type_expr * type_expr) list diff --git a/typing/env.ml b/typing/env.ml index 506975f7e..8d665fad6 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -60,6 +60,8 @@ type error = exception Error of error +let error err = raise (Error err) + module EnvLazy : sig type ('a,'b) t @@ -289,7 +291,7 @@ let check_consistency filename crcs = (fun (name, crc) -> Consistbl.check crc_units name crc filename) crcs with Consistbl.Inconsistency(name, source, auth) -> - raise(Error(Inconsistent_import(name, auth, source))) + error (Inconsistent_import(name, auth, source)) (* Reading persistent structures from .cmi files *) @@ -310,12 +312,12 @@ let read_pers_struct modname filename = ( ps_filename = filename; ps_flags = flags } in if ps.ps_name <> modname then - raise(Error(Illegal_renaming(modname, ps.ps_name, filename))); + error (Illegal_renaming(modname, ps.ps_name, filename)); check_consistency filename ps.ps_crcs; List.iter (function Rectypes -> if not !Clflags.recursive_types then - raise(Error(Need_recursive_types(ps.ps_name, !current_unit)))) + error (Need_recursive_types(ps.ps_name, !current_unit))) ps.ps_flags; Hashtbl.add persistent_structures modname (Some ps); ps @@ -1603,3 +1605,11 @@ let report_error ppf = function fprintf ppf "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]" export import "The compilation flag -rectypes is required" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + diff --git a/typing/includemod.ml b/typing/includemod.ml index 086dfe4d8..f270f4b1e 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -486,3 +486,14 @@ let report_error ppf errs = in let print_errs ppf = List.iter (include_err' ppf) in fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err + + +(* We could do a better job to split the individual error items + as sub-messages of the main interface mismatch on the whole unit. *) +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + diff --git a/typing/typeclass.ml b/typing/typeclass.ml index c28a07131..9a0fadf32 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1784,3 +1784,12 @@ let report_error env ppf = function let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | _ -> + None + ) diff --git a/typing/typecore.ml b/typing/typecore.ml index 98c6bdf89..9b6567710 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -3778,4 +3778,13 @@ let report_error env ppf err = wrap_printing_env env (fun () -> report_error env ppf err) let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | _ -> + None + ) + +let () = Env.add_delayed_check_forward := add_delayed_check diff --git a/typing/typecore.mli b/typing/typecore.mli index 71d75aa1b..edb8a53b8 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -111,6 +111,7 @@ type error = exception Error of Location.t * Env.t * error val report_error: Env.t -> formatter -> error -> unit + (* Deprecated. Use Location.{error_of_exn, report_error}. *) (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref diff --git a/typing/typedecl.ml b/typing/typedecl.ml index d80a33d69..cee2ededf 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1344,3 +1344,12 @@ let report_error ppf = function "cannot be checked" | Exception_constructor_with_result -> fprintf ppf "Exception constructors cannot specify a result type" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff --git a/typing/typemod.ml b/typing/typemod.ml index 439872b09..ad1204be8 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1569,3 +1569,12 @@ let report_error ppf = function let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error ppf err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | _ -> + None + ) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 7d6a9f864..5f1b20d4a 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -824,3 +824,13 @@ let report_error env ppf = function fprintf ppf "Illegal recursive module reference" | Extension s -> fprintf ppf "Uninterpreted extension '%s'." s + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | _ -> + None + ) + |