Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Location: significantly rework the code printing errors and warnings

master
Armaël Guéneau 2018-07-27 14:22:22 +02:00
parent 818dc938f0
commit c0820e30cb
59 changed files with 716 additions and 618 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bytecomp/translclass.ml
View File

@ -926,7 +926,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| _ ->
None
)

2
bytecomp/translcore.ml
View File

@ -909,7 +909,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| _ ->
None
)

2
bytecomp/translmod.ml
View File

@ -1375,7 +1375,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| _ ->
None
)

2
bytecomp/translprim.ml
View File

@ -756,7 +756,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| _ ->
None
)

9
driver/compenv.ml
View File

@ -476,8 +476,9 @@ let scan_line ic =
let load_config ppf filename =
match open_in_bin filename with
| exception e ->
Location.print_error ppf (Location.in_file filename);
Format.fprintf ppf "Cannot open file %s@." (Printexc.to_string e);
Location.errorf ~loc:(Location.in_file filename)
"Cannot open file %s" (Printexc.to_string e)
|> Location.print_report ppf;
raise Exit
| ic ->
let sic = Scanf.Scanning.from_channel ic in
@ -500,8 +501,8 @@ let load_config ppf filename =
loc_ghost = false;
}
in
Location.print_error ppf loc;
Format.fprintf ppf "Configuration file error %s@." error;
Location.errorf ~loc "Configuration file error %s" error
|> Location.print_report ppf;
close_in ic;
raise Exit
| line ->

5
driver/makedepend.ml
View File

@ -460,9 +460,8 @@ let sort_files_by_dependencies files =
done;
if !worklist <> [] then begin
Format.fprintf Format.err_formatter
"@[%t: cycle in dependencies. End of list is not sorted.@]@."
Location.print_error_prefix;
Location.error "cycle in dependencies. End of list is not sorted."
|> Location.print_report Format.err_formatter;
let sorted_deps =
let li = ref [] in
Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h;

16
middle_end/internal_variable_names.ml
View File

@ -17,7 +17,6 @@ open! Int_replace_polymorphic_compare
type t = string
let anon_fn = "anon_fn"
let apply_arg = "apply_arg"
let apply_funct = "apply_funct"
let block_symbol = "block_symbol"
@ -291,12 +290,15 @@ let toplevel_substitution_named = "toplevel_substitution_named"
let unbox_free_vars_of_closures = "unbox_free_vars_of_closures"
let zero = "zero"
let anon_fn_with_loc_fmt = format_of_string "anon_fn[%a]"
let anon_fn_with_loc loc =
if loc.Location.loc_ghost then anon_fn
else begin
Format.asprintf anon_fn_with_loc_fmt Location.print_compact loc
end
let anon_fn_with_loc (loc: Location.t) =
let (file, line, startchar) = Location.get_pos_info loc.loc_start in
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in
let pp_chars ppf =
if startchar >= 0 then Format.fprintf ppf ",%i--%i" startchar endchar in
if loc.Location.loc_ghost then "anon_fn"
else
Format.asprintf "anon_fn[%a:%i%t]"
Location.print_filename file line pp_chars
let of_primitive : Lambda.primitive -> string = function
| Pidentity -> pidentity

10
middle_end/middle_end.ml
View File

@ -37,7 +37,7 @@ let middle_end ~ppf_dump ~prefixname ~backend
~module_ident
~module_initializer =
Profile.record_call "flambda" (fun () ->
let previous_warning_printer = !Location.warning_printer in
let previous_warning_reporter = !Location.warning_reporter in
let module WarningSet =
Set.Make (struct
type t = Location.t * Warnings.t
@ -45,15 +45,15 @@ let middle_end ~ppf_dump ~prefixname ~backend
end)
in
let warning_set = ref WarningSet.empty in
let flambda_warning_printer loc ppf w =
let flambda_warning_reporter loc w =
let elt = loc, w in
if not (WarningSet.mem elt !warning_set) then begin
warning_set := WarningSet.add elt !warning_set;
previous_warning_printer loc ppf w
end;
previous_warning_reporter loc w
end else None
in
Misc.protect_refs
[Misc.R (Location.warning_printer, flambda_warning_printer)]
[Misc.R (Location.warning_reporter, flambda_warning_reporter)]
(fun () ->
let pass_number = ref 0 in
let round_number = ref 0 in

21
parsing/ast_mapper.ml
View File

@ -663,11 +663,22 @@ let default_mapper =
);
}
let rec extension_of_error {loc; msg; if_highlight; sub} =
{ loc; txt = "ocaml.error" },
PStr ([Str.eval (Exp.constant (Pconst_string (msg, None)));
Str.eval (Exp.constant (Pconst_string (if_highlight, None)))] @
(List.map (fun ext -> Str.extension (extension_of_error ext)) sub))
let extension_of_error {kind; main; sub} =
if kind <> Location.Report_error then
raise (Invalid_argument "extension_of_error: expected kind Report_error");
let str_of_pp pp_msg =
let b = Buffer.create 15 in
let ppf = Format.formatter_of_buffer b in
pp_msg ppf; Format.pp_print_flush ppf ();
Buffer.contents b
in
let extension_of_sub sub =
{ loc = sub.loc; txt = "ocaml.error" },
PStr ([Str.eval (Exp.constant (Pconst_string (str_of_pp sub.txt, None)))])
in
{ loc = main.loc; txt = "ocaml.error" },
PStr (Str.eval (Exp.constant (Pconst_string (str_of_pp main.txt, None))) ::
List.map (fun msg -> Str.extension (extension_of_sub msg)) sub)
let attribute_of_warning loc s =
Attr.mk

2
parsing/attr_helper.ml
View File

@ -48,7 +48,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| _ ->
None
)

55
parsing/builtin_attributes.ml
View File

@ -30,32 +30,39 @@ let string_of_opt_payload p =
| Some s -> s
| None -> ""
let rec error_of_extension ext =
let error_of_extension ext =
let submessage_from main_loc main_txt = function
| {pstr_desc=Pstr_extension
(({txt = ("ocaml.error"|"error"); loc}, p), _)} ->
begin match p with
| PStr([{pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}]) ->
{ Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg }
| _ ->
{ Location.loc; txt = fun ppf ->
Format.fprintf ppf
"Invalid syntax for sub-message of extension '%s'." main_txt }
end
| {pstr_desc=Pstr_extension (({txt; loc}, _), _)} ->
{ Location.loc; txt = fun ppf ->
Format.fprintf ppf "Uninterpreted extension '%s'." txt }
| _ ->
{ Location.loc = main_loc; txt = fun ppf ->
Format.fprintf ppf
"Invalid syntax for sub-message of extension '%s'." main_txt }
in
match ext with
| ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
let rec sub_from inner =
match inner with
| {pstr_desc=Pstr_extension (ext, _)} :: rest ->
error_of_extension ext :: sub_from rest
| _ :: rest ->
(Location.errorf ~loc
"Invalid syntax for sub-error of extension '%s'." txt) ::
sub_from rest
| [] -> []
in
begin match p with
| PStr [] -> raise Location.Already_displayed_error
| PStr({pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::
{pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Pconst_string(if_highlight,_))}, _)}::
inner) ->
Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg
| PStr({pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::inner) ->
Location.error ~loc ~sub:(sub_from inner) msg
| _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt
end
begin match p with
| PStr [] -> raise Location.Already_displayed_error
| PStr({pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::
inner) ->
let sub = List.map (submessage_from loc txt) inner in
Location.error_of_printer ~loc ~sub Format.pp_print_text msg
| _ ->
Location.errorf ~loc "Invalid syntax for extension '%s'." txt
end
| ({txt; loc}, _) ->
Location.errorf ~loc "Uninterpreted extension '%s'." txt

5
parsing/lexer.mli
View File

@ -32,11 +32,6 @@ type error =
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;;

35
parsing/lexer.mll
View File

@ -247,35 +247,36 @@ let comments () = List.rev !comment_list
open Format
let report_error ppf = function
let prepare_error loc = function
| Illegal_character c ->
fprintf ppf "Illegal character (%s)" (Char.escaped c)
Location.errorf ~loc "Illegal character (%s)" (Char.escaped c)
| Illegal_escape s ->
fprintf ppf "Illegal backslash escape in string or character (%s)" s
Location.errorf ~loc
"Illegal backslash escape in string or character (%s)" s
| Unterminated_comment _ ->
fprintf ppf "Comment not terminated"
Location.errorf ~loc "Comment not terminated"
| Unterminated_string ->
fprintf ppf "String literal not terminated"
| Unterminated_string_in_comment (_, loc) ->
fprintf ppf "This comment contains an unterminated string literal@.\
%aString literal begins here"
Location.print_error loc
Location.errorf ~loc "String literal not terminated"
| Unterminated_string_in_comment (_, literal_loc) ->
Location.errorf ~loc
"This comment contains an unterminated string literal"
~sub:[Location.msg ~loc:literal_loc "String literal begins here"]
| Keyword_as_label kwd ->
fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
Location.errorf ~loc
"`%s' is a keyword, it cannot be used as label name" kwd
| Invalid_literal s ->
fprintf ppf "Invalid literal %s" s
Location.errorf ~loc "Invalid literal %s" s
| Invalid_directive (dir, explanation) ->
fprintf ppf "Invalid lexer directive %S" dir;
begin match explanation with
| None -> ()
| Some expl -> fprintf ppf ": %s" expl
end
Location.errorf ~loc "Invalid lexer directive %S%t" dir
(fun ppf -> match explanation with
| None -> ()
| Some expl -> fprintf ppf ": %s" expl)
let () =
Location.register_error_of_exn
(function
| Error (err, loc) ->
Some (Location.error_of_printer loc report_error err)
Some (prepare_error loc err)
| _ ->
None
)

357
parsing/location.ml
View File

@ -93,6 +93,10 @@ let input_lexbuf = ref (None : lexbuf option)
let status = ref Terminfo.Uninitialised
let setup_terminal () =
if !status = Terminfo.Uninitialised then
status := Terminfo.setup stdout
(* The number of lines already printed after input.
This is used by [highlight_terminfo] to identify the current position of the
@ -236,7 +240,7 @@ let print_locs ppf locs =
If [locs] is empty, this function is a no-op.
*)
let highlight_terminfo ppf lb locs =
let highlight_terminfo lb ppf 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
@ -270,6 +274,10 @@ let highlight_terminfo ppf lb locs =
Terminfo.resume stdout !num_loc_lines;
flush stdout
let highlight_terminfo lb ppf locs =
try highlight_terminfo lb ppf locs
with Exit -> ()
(* Highlight the location by printing it again.
There are two different styles for highlighting errors in "dumb" mode,
@ -297,7 +305,7 @@ let highlight_terminfo ppf lb locs =
If [locs] is empty then this function is a no-op.
*)
let highlight_dumb ~print_chars ppf lb locs =
let highlight_dumb ~print_chars lb ppf locs =
let locs' = Misc.Stdlib.List.filter_map (fun loc ->
let s, e = loc.loc_start.pos_cnum, loc.loc_end.pos_cnum in
(* Ignore dummy locations *)
@ -377,172 +385,210 @@ let highlight_dumb ~print_chars ppf lb locs =
Format.fprintf ppf "@]@,@]"
end
let show_code_at_location ppf lb locs =
try highlight_dumb ~print_chars:false ppf lb locs
let highlight_dumb ~print_chars lb ppf locs =
try highlight_dumb ~print_chars lb ppf locs
with Exit -> ()
(* Highlight the location using one of the supported modes. *)
(* Return the "best" highlighting function depending on the capabilities of the
terminal. *)
let highlight_locations ppf locs =
setup_terminal ();
let norepeat =
try Sys.getenv "TERM" = "norepeat" with Not_found -> false
in
match !status, !input_lexbuf, norepeat with
| Terminfo.Good_term, Some lb, _ ->
highlight_terminfo lb ppf locs
| Terminfo.Bad_term, Some lb, false ->
highlight_dumb ~print_chars:true lb ppf locs
| _, _, _ ->
Format.fprintf ppf "@[<v>%a:@,@]" print_locs locs
let rec highlight_locations ppf locs =
match !status with
Terminfo.Uninitialised ->
status := Terminfo.setup stdout; highlight_locations ppf locs
| Terminfo.Bad_term ->
begin match !input_lexbuf with
None -> false
| Some lb ->
let norepeat =
try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
if norepeat then false else
try highlight_dumb ~print_chars:true ppf lb locs; true
with Exit -> false
end
| Terminfo.Good_term ->
begin match !input_lexbuf with
None -> false
| Some lb ->
try highlight_terminfo ppf lb locs; true
with Exit -> false
end
(******************************************************************************)
(* Reporting errors and warnings *)
let default_printer ppf loc =
setup_colors ();
if loc.loc_start.pos_fname = "//toplevel//"
&& highlight_locations ppf [loc] then ()
else Format.fprintf ppf "@{<loc>%a@}:@," print_loc loc
;;
type msg = (Format.formatter -> unit) loc
let printer = ref default_printer
let print ppf loc = !printer ppf loc
let msg ?(loc = none) fmt =
Format.kdprintf (fun txt -> { loc; txt }) fmt
let print_compact ppf loc =
if loc.loc_start.pos_fname = "//toplevel//"
&& highlight_locations ppf [loc] then ()
else begin
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
Format.fprintf ppf "%a:%i" print_filename file line;
if startchar >= 0 then Format.fprintf ppf ",%i--%i" startchar endchar
end
;;
type report_kind =
| Report_error
| Report_warning of int
| Report_warning_as_error of int
type report = {
kind : report_kind;
main : msg;
sub : msg list;
}
type report_printer = {
(* The entry point *)
pp : report_printer ->
Format.formatter -> report -> unit;
pp_report_kind : report_printer -> report ->
Format.formatter -> report_kind -> unit;
pp_main_loc : report_printer -> report ->
Format.formatter -> t -> unit;
pp_main_txt : report_printer -> report ->
Format.formatter -> (Format.formatter -> unit) -> unit;
pp_submsgs : report_printer -> report ->
Format.formatter -> msg list -> unit;
pp_submsg : report_printer -> report ->
Format.formatter -> msg -> unit;
pp_submsg_loc : report_printer -> report ->
Format.formatter -> t -> unit;
pp_submsg_txt : report_printer -> report ->
Format.formatter -> (Format.formatter -> unit) -> unit;
}
let batch_mode_printer : report_printer =
let pp_loc ppf loc = Format.fprintf ppf "%a:@," print_loc loc in
let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
let pp self ppf report =
setup_colors ();
Format.fprintf ppf "@[<v>%a%a: @[<v>%a%a@]@]@."
(self.pp_main_loc self report) report.main.loc
(self.pp_report_kind self report) report.kind
(self.pp_main_txt self report) report.main.txt
(self.pp_submsgs self report) report.sub
in
let pp_report_kind _self _ ppf = function
| Report_error -> Format.fprintf ppf "@{<error>Error@}"
| Report_warning w -> Format.fprintf ppf "@{<warning>Warning@} %d" w
| Report_warning_as_error w ->
Format.fprintf ppf "@{<error>Error@} (warning %d)" w
in
let pp_main_loc _self _ ppf loc =
pp_loc ppf loc
in
let pp_main_txt _self _ ppf txt =
pp_txt ppf txt
in
let pp_submsgs self report ppf msgs =
List.iter (fun msg ->
Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg
) msgs
in
let pp_submsg self report ppf { loc; txt } =
Format.fprintf ppf "%a%a"
(self.pp_submsg_loc self report) loc
(self.pp_submsg_txt self report) txt
in
let pp_submsg_loc _self _ ppf loc =
if not loc.loc_ghost then
pp_loc ppf loc
in
let pp_submsg_txt _self _ ppf loc =
pp_txt ppf loc
in
{ pp; pp_report_kind; pp_main_loc; pp_main_txt;
pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt }
let is_dummy_loc loc =
(* Fixme: this should be just [loc.loc_ghost] and the function should be
inlined below. However, currently, the compiler emits in some places ghost
locations with valid ranges that should still be printed. These locations
should be made non-ghost -- in the meantime we just check if the ranges are
valid. *)
loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1
let toplevel_printer
~(highlight: Format.formatter -> t list -> unit):
report_printer
=
let super = batch_mode_printer in
let pp self ppf err =
setup_colors ();
(* Since we're printing in the toplevel, we have to keep [num_loc_lines]
updated. *)
print_updating_num_loc_lines ppf (fun ppf err ->
(* Highlight all toplevel locations of the report, instead of displaying
the main location. Do it now instead of in [pp_main_loc], to avoid
messing with Format boxes. *)
let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in
let all_locs = err.main.loc :: sub_locs in
let locs_highlighted = List.filter (fun loc ->
not (is_dummy_loc loc)
&& loc.loc_start.pos_fname = "//toplevel//"
&& loc.loc_end.pos_fname = "//toplevel//"
) all_locs in
highlight ppf locs_highlighted;
super.pp self ppf err
) err
in
let pp_main_loc _self _ _ _ =
()
in
{ super with pp; pp_main_loc }
(* Creates a printer for the current input *)
let default_report_printer () : report_printer =
if !input_name = "//toplevel//" then begin
toplevel_printer ~highlight:highlight_locations
end else
batch_mode_printer
let report_printer = ref default_report_printer
let print_report ppf report =
let printer = !report_printer () in
printer.pp printer ppf report
(******************************************************************************)
(* Reporting errors *)
let error_prefix = "Error"
let print_error_prefix ppf =
setup_colors ();
Format.fprintf ppf "@{<error>%s@}" error_prefix;
;;
let print_error ppf loc =
Format.fprintf ppf "%a%t:" print loc print_error_prefix
let print_error_cur_file ppf () = print_error ppf (in_file !input_name);;
type error =
{
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
let pp_ksprintf ?before k fmt =
let buf = Buffer.create 64 in
let ppf = Format.formatter_of_buffer buf in
Misc.Color.set_color_tag_handling ppf;
begin match before with
| None -> ()
| Some f -> f ppf
end;
Format.kfprintf
(fun _ ->
Format.pp_print_flush ppf ();
let msg = Buffer.contents buf in
k msg)
ppf fmt
(* Shift the formatter's offset by the length of the error prefix, which
is always added by the compiler after the message has been formatted *)
let print_phantom_error_prefix ppf =
Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""
let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
pp_ksprintf
~before:print_phantom_error_prefix
(fun msg -> {loc; msg; sub; if_highlight})
fmt
let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg =
{loc; msg; sub; if_highlight}
let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
let highlighted =
if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then
let rec collect_locs locs {loc; sub; _} =
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
Format.fprintf ppf "@[<v>%a %s" print_error loc msg;
List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub;
Format.fprintf ppf "@]"
end
let error_reporter = ref default_error_reporter
type error = report
let report_error ppf err =
print_updating_num_loc_lines ppf !error_reporter err
;;
print_report ppf err
let error_of_printer loc print x =
errorf ~loc "%a@?" print x
let mkerror loc sub txt =
{ kind = Report_error; main = { loc; txt }; sub }
let errorf ?(loc = none) ?(sub = []) =
Format.kdprintf (mkerror loc sub)
let error ?(loc = none) ?(sub = []) msg_str =
mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str)
let error_of_printer ?(loc = none) ?(sub = []) pp x =
mkerror loc sub (fun ppf -> pp ppf x)
let error_of_printer_file print x =
error_of_printer (in_file !input_name) print x
error_of_printer ~loc:(in_file !input_name) print x
(******************************************************************************)
(* Reporting warnings *)
(* Reporting warnings: generating a report from a warning number using the
information in [Warnings] + convenience functions. *)
let warning_prefix = "Warning"
let default_warning_printer loc ppf w =
let default_warning_reporter (loc: t) (w: Warnings.t): report option =
match Warnings.report w with
| `Inactive -> ()
| `Active { Warnings. number; message; is_error; sub_locs } ->
setup_colors ();
Format.fprintf ppf "@[<v>";
print ppf loc;
if is_error
then
Format.fprintf ppf "%t (%s %d): %s@," print_error_prefix
(String.uncapitalize_ascii warning_prefix) number message
else
Format.fprintf ppf "@{<warning>%s@} %d: %s@," warning_prefix
number message;
List.iter
(fun (loc, msg) ->
if loc <> none then Format.fprintf ppf " %a %s@," print loc msg
)
sub_locs;
Format.fprintf ppf "@]"
| `Inactive -> None
| `Active { Warnings.number; message; is_error; sub_locs } ->
let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in
let kind =
if is_error then Report_warning_as_error number
else Report_warning number in
let main = { loc; txt = msg_of_str message } in
let sub = List.map (fun (loc, sub_message) ->
{ loc; txt = msg_of_str sub_message }
) sub_locs in
Some { kind; main; sub }
let warning_printer = ref default_warning_printer ;;
let warning_reporter = ref default_warning_reporter
let report_warning loc w = !warning_reporter loc w
let formatter_for_warnings = ref Format.err_formatter
let print_warning loc ppf w =
print_updating_num_loc_lines ppf (!warning_printer loc) w
;;
match report_warning loc w with
| None -> ()
| Some report -> print_report ppf report
let formatter_for_warnings = ref Format.err_formatter;;
let prerr_warning loc w = print_warning loc !formatter_for_warnings w;;
let prerr_warning loc w = print_warning loc !formatter_for_warnings w
let deprecated ?(def = none) ?(use = none) loc msg =
prerr_warning loc (Warnings.Deprecated (msg, def, use))
@ -573,19 +619,18 @@ let () =
register_error_of_exn
(function
| Sys_error msg ->
Some (errorf ~loc:(in_file !input_name)
"I/O error: %s" msg)
Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg)
| Misc.HookExnWrapper {error = e; hook_name;
hook_info={Misc.sourcefile}} ->
let sub = match error_of_exn e with
| None | Some `Already_displayed -> error (Printexc.to_string e)
| Some (`Ok err) -> err
| None | Some `Already_displayed ->
[msg "%s" (Printexc.to_string e)]
| Some (`Ok err) ->
(msg ~loc:err.main.loc "%t" err.main.txt) :: err.sub
in
Some
(errorf ~loc:(in_file sourcefile)
"In hook %S:" hook_name
~sub:[sub])
(errorf ~loc:(in_file sourcefile) ~sub "In hook %S:" hook_name)
| _ -> None
)
@ -596,7 +641,7 @@ let report_exception ppf exn =
match error_of_exn exn with
| None -> reraise exn
| Some `Already_displayed -> ()
| Some (`Ok err) -> Format.fprintf ppf "@[%a@]@." report_error err
| Some (`Ok err) -> report_error ppf err
| exception exn when n > 0 -> loop (n-1) exn
in
loop 5 exn
@ -610,7 +655,5 @@ let () =
| _ -> None
)
let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
pp_ksprintf
~before:print_phantom_error_prefix
(fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
let raise_errorf ?(loc = none) ?(sub = []) =
Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt)))

138
parsing/location.mli
View File

@ -92,71 +92,125 @@ val show_filename: string -> string
val print_filename: formatter -> string -> unit
val print_loc: formatter -> t -> unit
val default_printer : formatter -> t -> unit
val printer : (formatter -> t -> unit) ref
val print: formatter -> t -> unit
val print_compact: formatter -> t -> unit
val print_locs: formatter -> t list -> unit
(** {1 Toplevel-specific location highlighting} *)
val highlight_locations: formatter -> t list -> bool
val highlight_terminfo:
Lexing.lexbuf -> formatter -> t list -> unit
val show_code_at_location: formatter -> Lexing.lexbuf -> t list -> unit
val highlight_dumb:
print_chars:bool -> Lexing.lexbuf -> formatter -> t list -> unit
val highlight_locations:
formatter -> t list -> unit
(** {1 Reporting errors and warnings} *)
type msg = (Format.formatter -> unit) loc
val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a
type report_kind =
| Report_error
| Report_warning of int
| Report_warning_as_error of int
type report = {
kind : report_kind;
main : msg;
sub : msg list;
}
type report_printer = {
(* The entry point *)
pp : report_printer ->
Format.formatter -> report -> unit;
pp_report_kind : report_printer -> report ->
Format.formatter -> report_kind -> unit;
pp_main_loc : report_printer -> report ->
Format.formatter -> t -> unit;
pp_main_txt : report_printer -> report ->
Format.formatter -> (Format.formatter -> unit) -> unit;
pp_submsgs : report_printer -> report ->
Format.formatter -> msg list -> unit;
pp_submsg : report_printer -> report ->
Format.formatter -> msg -> unit;
pp_submsg_loc : report_printer -> report ->
Format.formatter -> t -> unit;
pp_submsg_txt : report_printer -> report ->
Format.formatter -> (Format.formatter -> unit) -> unit;
}
(** A printer for [report]s, defined using open-recursion.
The goal is to make it easy to define new printers by re-using code from
existing ones.
*)
val batch_mode_printer: report_printer
val toplevel_printer:
highlight:(formatter -> t list -> unit) ->
report_printer
val print_report: formatter -> report -> unit
(** Display an error or warning report. *)
val report_printer: (unit -> report_printer) ref
(** Hook for redefining the printer of reports. *)
val default_report_printer: unit -> report_printer
(** Original report printer for use in hooks. *)
(** {1 Reporting warnings} *)
val print_warning: t -> formatter -> Warnings.t -> unit
val formatter_for_warnings : formatter ref
val prerr_warning: t -> Warnings.t -> unit
(** {2 Converting a [Warnings.t] into a [report]} *)
val warning_printer : (t -> formatter -> Warnings.t -> unit) ref
val report_warning: t -> Warnings.t -> report option
(** [report_warning loc w] produces a report for the given warning [w], or
[None] if the warning is not to be printed. *)
val warning_reporter: (t -> Warnings.t -> report option) ref
(** Hook for intercepting warnings. *)
val default_warning_printer : t -> formatter -> Warnings.t -> unit
(** Original warning printer for use in hooks. *)
val default_warning_reporter: t -> Warnings.t -> report option
(** Original warning reporter for use in hooks. *)
(** {2 Printing warnings} *)
val formatter_for_warnings : formatter ref
val print_warning: t -> formatter -> Warnings.t -> unit
(** Prints a warning. This is simply the composition of [report_warning] and
[print_report]. *)
val prerr_warning: t -> Warnings.t -> unit
(** Same as [print_warning], but uses [!formatter_for_warnings] as output
formatter. *)
val deprecated: ?def:t -> ?use:t -> t -> string -> unit
(** Print a deprecation warning. *)
(** Prints a deprecation warning. *)
(** {1 Reporting errors} *)
val print_error_prefix: formatter -> unit
val print_error: formatter -> t -> unit
val print_error_cur_file: formatter -> unit -> unit
type error = report
(** An [error] is a [report] which [report_kind] must be [Report_error]. *)
(** Support for located errors *)
val error: ?loc:t -> ?sub:msg list -> string -> error
type error =
{
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
val errorf: ?loc:t -> ?sub:msg list ->
('a, Format.formatter, unit, error) format4 -> 'a
val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
-> ('a, Format.formatter, unit, error) format4 -> 'a
val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error
val error_of_printer: ?loc:t -> ?sub:msg list ->
(formatter -> 'a -> unit) -> 'a -> error
val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
val report_error: formatter -> error -> unit
val error_reporter : (formatter -> error -> unit) ref
(** Hook for intercepting error reports. *)
val default_error_reporter : formatter -> error -> unit
(** Original error reporter for use in hooks. *)
(** {1 Automatically reportitng errors for raised exceptions} *)
(** {1 Automatically reporting errors for raised exceptions} *)
val register_error_of_exn: (exn -> error option) -> unit
(** Each compiler module which defines a custom type of exception
@ -176,8 +230,8 @@ exception Already_displayed_error
(** Raising [Already_displayed_error] signals an error which has already been
printed. The exception will be caught, but nothing will be printed *)
val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
-> ('a, Format.formatter, unit, 'b) format4 -> 'a
val raise_errorf: ?loc:t -> ?sub:msg list ->
('a, Format.formatter, unit, 'b) format4 -> 'a
val report_exception: formatter -> exn -> unit
(** Reraise the exception if it is unknown. *)

19
parsing/syntaxerr.ml
View File

@ -28,17 +28,15 @@ type error =
exception Error of error
exception Escape_error
let prepare_error = function
let prepare_error err =
match err with
| Unclosed(opening_loc, opening, closing_loc, closing) ->
Location.errorf ~loc:closing_loc
Location.errorf
~loc:closing_loc
~sub:[
Location.errorf ~loc:opening_loc
Location.msg ~loc:opening_loc
"This '%s' might be unmatched" opening
]
~if_highlight:
(Printf.sprintf "Syntax error: '%s' expected, \
the highlighted '%s' might be unmatched"
closing opening)
"Syntax error: '%s' expected" closing
| Expecting (loc, nonterm) ->
@ -53,11 +51,12 @@ let prepare_error = function
Location.errorf ~loc
"In this scoped type, variable '%s \
is reserved for the local type %s."
var var
var var
| Other loc ->
Location.errorf ~loc "Syntax error"
| Ill_formed_ast (loc, s) ->
Location.errorf ~loc "broken invariant in parsetree: %s" s
Location.errorf ~loc
"broken invariant in parsetree: %s" s
| Invalid_package_type (loc, s) ->
Location.errorf ~loc "invalid package type: %s" s
@ -70,7 +69,7 @@ let () =
let report_error ppf err =
Location.report_error ppf (prepare_error err)
Location.print_report ppf (prepare_error err)
let location_of_error = function
| Unclosed(l,_,_,_)

1
testsuite/tests/formatting/margins.ml
View File

@ -7,5 +7,6 @@ let () = Format.pp_set_margin Format.std_formatter 20;;
1 + "foo";;
let () = Format.pp_set_margin Format.std_formatter 80;;
let () = Format.pp_set_max_indent Format.std_formatter 70;;
1 + "foo";;

4
testsuite/tests/parse-errors/unclosed_class_simpl_expr2.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_class_simpl_expr2.ml", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_class_simpl_expr2.ml", line 8, characters 10-11:
Error: This '(' might be unmatched
File "unclosed_class_simpl_expr2.ml", line 8, characters 10-11:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_class_simpl_expr3.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_class_simpl_expr3.ml", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_class_simpl_expr3.ml", line 8, characters 10-11:
Error: This '(' might be unmatched
File "unclosed_class_simpl_expr3.ml", line 8, characters 10-11:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_paren_module_expr1.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_paren_module_expr1.ml", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_paren_module_expr1.ml", line 8, characters 11-12:
Error: This '(' might be unmatched
File "unclosed_paren_module_expr1.ml", line 8, characters 11-12:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_paren_module_expr2.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_paren_module_expr2.ml", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_paren_module_expr2.ml", line 8, characters 11-12:
Error: This '(' might be unmatched
File "unclosed_paren_module_expr2.ml", line 8, characters 11-12:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_paren_module_expr3.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_paren_module_expr3.ml", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_paren_module_expr3.ml", line 8, characters 11-12:
Error: This '(' might be unmatched
File "unclosed_paren_module_expr3.ml", line 8, characters 11-12:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_paren_module_expr4.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_paren_module_expr4.ml", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_paren_module_expr4.ml", line 8, characters 11-12:
Error: This '(' might be unmatched
File "unclosed_paren_module_expr4.ml", line 8, characters 11-12:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_paren_module_expr5.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_paren_module_expr5.ml", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_paren_module_expr5.ml", line 8, characters 11-12:
Error: This '(' might be unmatched
File "unclosed_paren_module_expr5.ml", line 8, characters 11-12:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_paren_module_type.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_paren_module_type.mli", line 9, characters 0-0:
Error: Syntax error: ')' expected
File "unclosed_paren_module_type.mli", line 8, characters 11-12:
Error: This '(' might be unmatched
File "unclosed_paren_module_type.mli", line 8, characters 11-12:
This '(' might be unmatched

4
testsuite/tests/parse-errors/unclosed_sig.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_sig.mli", line 10, characters 0-0:
Error: Syntax error: 'end' expected
File "unclosed_sig.mli", line 8, characters 11-14:
Error: This 'sig' might be unmatched
File "unclosed_sig.mli", line 8, characters 11-14:
This 'sig' might be unmatched

122
testsuite/tests/parse-errors/unclosed_simple_expr.compilers.reference
View File

@ -1,61 +1,87 @@
Line 5, characters 0-1, Line 5, characters 5-7: (3; 2;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 2, characters 0-5,
Line 2, characters 10-12:
Line 5, characters 5-7,
Line 5, characters 0-1:
(3; 2;;
^ ^^
Error: Syntax error: ')' expected
Line 5, characters 0-1:
This '(' might be unmatched
Line 2, characters 10-12,
Line 2, characters 0-5:
begin 3; 2;;
^^^^^ ^^
Syntax error: 'end' expected, the highlighted 'begin' might be unmatched
Line 2, characters 5-6,
Line 2, characters 10-12:
Error: Syntax error: 'end' expected
Line 2, characters 0-5:
This 'begin' might be unmatched
Line 2, characters 10-12,
Line 2, characters 5-6:
List.(3; 2;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 2, characters 12-13,
Line 2, characters 17-19:
Error: Syntax error: ')' expected
Line 2, characters 5-6:
This '(' might be unmatched
Line 2, characters 17-19,
Line 2, characters 12-13:
simple_expr.(3; 2;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 2, characters 12-13,
Line 2, characters 17-19:
Error: Syntax error: ')' expected
Line 2, characters 12-13:
This '(' might be unmatched
Line 2, characters 17-19,
Line 2, characters 12-13:
simple_expr.[3; 2;;
^ ^^
Syntax error: ']' expected, the highlighted '[' might be unmatched
Line 2, characters 13-14,
Line 2, characters 15-17:
Error: Syntax error: ']' expected
Line 2, characters 12-13:
This '[' might be unmatched
Line 2, characters 15-17,
Line 2, characters 13-14:
simple_expr.%[3;;
^ ^^
Syntax error: ']' expected, the highlighted '[' might be unmatched
Line 2, characters 13-14,
Line 2, characters 15-17:
Error: Syntax error: ']' expected
Line 2, characters 13-14:
This '[' might be unmatched
Line 2, characters 15-17,
Line 2, characters 13-14:
simple_expr.%(3;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 2, characters 13-14,
Line 2, characters 15-17:
Error: Syntax error: ')' expected
Line 2, characters 13-14:
This '(' might be unmatched
Line 2, characters 15-17,
Line 2, characters 13-14:
simple_expr.%{3;;
^ ^^
Syntax error: '}' expected, the highlighted '{' might be unmatched
Line 2, characters 9-10,
Line 2, characters 11-13:
Error: Syntax error: '}' expected
Line 2, characters 13-14:
This '{' might be unmatched
Line 2, characters 11-13,
Line 2, characters 9-10:
foo.Bar.%[3;;
^ ^^
Syntax error: ']' expected, the highlighted '[' might be unmatched
Line 2, characters 9-10,
Line 2, characters 11-13:
Error: Syntax error: ']' expected
Line 2, characters 9-10:
This '[' might be unmatched
Line 2, characters 11-13,
Line 2, characters 9-10:
foo.Bar.%(3;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 2, characters 9-10,
Line 2, characters 11-13:
Error: Syntax error: ')' expected
Line 2, characters 9-10:
This '(' might be unmatched
Line 2, characters 11-13,
Line 2, characters 9-10:
foo.Bar.%{3;;
^ ^^
Syntax error: '}' expected, the highlighted '{' might be unmatched
Line 2, characters 12-13,
Line 2, characters 17-19:
Error: Syntax error: '}' expected
Line 2, characters 9-10:
This '{' might be unmatched
Line 2, characters 17-19,
Line 2, characters 12-13:
simple_expr.{3, 2;;
^ ^^
Syntax error: '}' expected, the highlighted '{' might be unmatched
Error: Syntax error: '}' expected
Line 2, characters 12-13:
This '{' might be unmatched
Line 2, characters 10-12:
{ x = 3; y;;
^^
@ -88,20 +114,26 @@ Line 2, characters 17-19:
List.{< x = 3; y ;;
^^
Error: Syntax error
Line 2, characters 0-1,
Line 2, characters 20-22:
Line 2, characters 20-22,
Line 2, characters 0-1:
(module struct end :;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 2, characters 5-6,
Line 2, characters 25-27:
Error: Syntax error: ')' expected
Line 2, characters 0-1:
This '(' might be unmatched
Line 2, characters 25-27,
Line 2, characters 5-6:
List.(module struct end :;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Error: Syntax error: ')' expected
Line 2, characters 5-6:
This '(' might be unmatched
Line 2, characters 0-1,
Line 2, characters 2-3:
Line 2, characters 2-3,
Line 2, characters 0-1:
(=;
^ ^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Error: Syntax error: ')' expected
Line 2, characters 0-1:
This '(' might be unmatched

26
testsuite/tests/parse-errors/unclosed_simple_pattern.compilers.reference
View File

@ -1,16 +1,24 @@
Line 6, characters 9-10, Line 7, characters 0-2: .........(.
;;
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 3, characters 4-5,
Line 4, characters 0-2:
Line 7, characters 0-2,
Line 6, characters 9-10:
.........(.
;;
Error: Syntax error: ')' expected
Line 6, characters 9-10:
This '(' might be unmatched
Line 4, characters 0-2,
Line 3, characters 4-5:
....(.
;;
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 3, characters 4-5,
Line 4, characters 0-2:
Error: Syntax error: ')' expected
Line 3, characters 4-5:
This '(' might be unmatched
Line 4, characters 0-2,
Line 3, characters 4-5:
....(.......
;;
Syntax error: ')' expected, the highlighted '(' might be unmatched
Error: Syntax error: ')' expected
Line 3, characters 4-5:
This '(' might be unmatched
Line 7, characters 0-2:
;;
^^

4
testsuite/tests/parse-errors/unclosed_struct.compilers.reference
View File

@ -1,4 +1,4 @@
File "unclosed_struct.ml", line 10, characters 0-0:
Error: Syntax error: 'end' expected
File "unclosed_struct.ml", line 8, characters 11-17:
Error: This 'struct' might be unmatched
File "unclosed_struct.ml", line 8, characters 11-17:
This 'struct' might be unmatched

32
testsuite/tests/tool-toplevel/error_highlighting.compilers.reference
View File

@ -3,27 +3,33 @@ Line 9, characters 8-15:
^^^^^^^
Error: This expression has type int but an expression was expected of type
float
Line 2, characters 8-9,
Line 2, characters 15-17:
Line 2, characters 15-17,
Line 2, characters 8-9:
let x = (1 + 2 in ();;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Line 2, characters 8-9,
Line 2, characters 14-16:
Error: Syntax error: ')' expected
Line 2, characters 8-9:
This '(' might be unmatched
Line 2, characters 14-16,
Line 2, characters 8-9:
let x = (1 + 2;;
^ ^^
Syntax error: ')' expected, the highlighted '(' might be unmatched
Error: Syntax error: ')' expected
Line 2, characters 8-9:
This '(' might be unmatched
Line 3, characters 8-9:
let y = 1 +. 2. in
^
Error: This expression has type int but an expression was expected of type
float
Line 2, characters 8-9,
Line 4, characters 2-4:
Line 4, characters 2-4,
Line 2, characters 8-9:
........(.
...
..in
Syntax error: ')' expected, the highlighted '(' might be unmatched
Error: Syntax error: ')' expected
Line 2, characters 8-9:
This '(' might be unmatched
Line 2, characters 8-17:
........(1
+
@ -35,12 +41,12 @@ Error: This expression has type int but an expression was expected of type
float
File "error_highlighting_use2.ml", line 1, characters 15-17:
Error: Syntax error: ')' expected
File "error_highlighting_use2.ml", line 1, characters 8-9:
Error: This '(' might be unmatched
File "error_highlighting_use2.ml", line 1, characters 8-9:
This '(' might be unmatched
File "error_highlighting_use3.ml", line 3, characters 2-4:
Error: Syntax error: ')' expected
File "error_highlighting_use3.ml", line 1, characters 8-9:
Error: This '(' might be unmatched
File "error_highlighting_use3.ml", line 1, characters 8-9:
This '(' might be unmatched
File "error_highlighting_use4.ml", line 1, characters 8-17:
Error: This expression has type int but an expression was expected of type
float

3
testsuite/tests/typing-core-bugs/type_expected_explanation.ml
View File

@ -77,8 +77,7 @@ Line 1, characters 3-15:
if (fun x -> x) then ();;
^^^^^^^^^^^^
Error: This expression should not be a function, the expected type is
bool
because it is in the condition of an if-statement
bool because it is in the condition of an if-statement
|}];;
while 42 do () done;;

28
testsuite/tests/typing-gadts/unexpected_existentials.ml
View File

@ -14,7 +14,7 @@ Line 1, characters 4-9:
let Any x = Any ()
^^^^^
Error: Existential types are not allowed in toplevel bindings,
but this pattern introduces the existential type $Any_'a.
but this pattern introduces the existential type $Any_'a.
|}]
let () =
@ -25,7 +25,7 @@ Line 2, characters 6-11:
let Any x = Any () and () = () in
^^^^^
Error: Existential types are not allowed in "let ... and ..." bindings,
but this pattern introduces the existential type $Any_'a.
but this pattern introduces the existential type $Any_'a.
|}]
@ -37,7 +37,7 @@ Line 2, characters 10-15:
let rec Any x = Any () in
^^^^^
Error: Existential types are not allowed in recursive bindings,
but this pattern introduces the existential type $Any_'a.
but this pattern introduces the existential type $Any_'a.
|}]
@ -49,7 +49,7 @@ Line 2, characters 18-23:
let[@attribute] Any x = Any () in
^^^^^
Error: Existential types are not allowed in presence of attributes,
but this pattern introduces the existential type $Any_'a.
but this pattern introduces the existential type $Any_'a.
|}]
@ -59,7 +59,7 @@ Line 1, characters 8-15:
class c (Any x) = object end
^^^^^^^
Error: Existential types are not allowed in class arguments,
but this pattern introduces the existential type $Any_'a.
but this pattern introduces the existential type $Any_'a.
|}]
class c = object(Any x)end
@ -68,7 +68,7 @@ Line 1, characters 16-23:
class c = object(Any x)end
^^^^^^^
Error: Existential types are not allowed in self patterns,
but this pattern introduces the existential type $Any_'a.
but this pattern introduces the existential type $Any_'a.
|}]
type other = Any: _ -> other
@ -82,7 +82,7 @@ Line 1, characters 4-9:
let Any x = Any ()
^^^^^
Error: Existential types are not allowed in toplevel bindings,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]
@ -92,7 +92,7 @@ Line 1, characters 14-20:
class c = let Any _x = () in object end
^^^^^^
Error: Existential types are not allowed in bindings inside class definition,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]
let () =
@ -103,7 +103,7 @@ Line 2, characters 6-11:
let Any x = Any () and () = () in
^^^^^
Error: Existential types are not allowed in "let ... and ..." bindings,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]
@ -115,7 +115,7 @@ Line 2, characters 10-15:
let rec Any x = Any () in
^^^^^
Error: Existential types are not allowed in recursive bindings,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]
@ -127,7 +127,7 @@ Line 2, characters 18-23:
let[@attribute] Any x = Any () in
^^^^^
Error: Existential types are not allowed in presence of attributes,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]
class c (Any x) = object end
@ -136,7 +136,7 @@ Line 1, characters 8-15:
class c (Any x) = object end
^^^^^^^
Error: Existential types are not allowed in class arguments,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]
class c = object(Any x) end
@ -145,7 +145,7 @@ Line 1, characters 16-23:
class c = object(Any x) end
^^^^^^^
Error: Existential types are not allowed in self patterns,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]
class c = let Any _x = () in object end
@ -154,5 +154,5 @@ Line 1, characters 14-20:
class c = let Any _x = () in object end
^^^^^^
Error: Existential types are not allowed in bindings inside class definition,
but the constructor Any introduces existential types.
but the constructor Any introduces existential types.
|}]

4
testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference
View File

@ -7,7 +7,7 @@ Line 1, characters 6-37:
let f (module M : S with type t = 'a) = M.x;; (* Error *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The type of this packed module contains variables:
(module S with type t = 'a)
(module S with type t = 'a)
val f : (module S with type t = 'a) -> 'a = <fun>
- : int = 1
type 'a s = { s : (module S with type t = 'a); }
@ -16,7 +16,7 @@ Line 1, characters 9-19:
let f {s=(module M)} = M.x;; (* Error *)
^^^^^^^^^^
Error: The type of this packed module contains variables:
(module S with type t = 'a)
(module S with type t = 'a)
val f : 'a s -> 'a = <fun>
type s = { s : (module S with type t = int); }
val f : s -> int = <fun>

132
testsuite/tests/typing-misc/pr6416.ml
View File

@ -27,13 +27,9 @@ Error: Signature mismatch:
is not included in
val f : t/2 -> unit
Line 6, characters 4-14:
type t = B
^^^^^^^^^^
Definition of type t/1
Line 2, characters 2-12:
type t = A
^^^^^^^^^^
Definition of type t/2
Definition of type t/1
Line 2, characters 2-12:
Definition of type t/2
|}]
module N = struct
@ -56,13 +52,9 @@ Error: Signature mismatch:
type u = A of t/2
The types for field A are not equal.
Line 4, characters 9-19:
struct type t = B type u = A of t end
^^^^^^^^^^
Definition of type t/1
Line 2, characters 2-11:
type t= A
^^^^^^^^^
Definition of type t/2
Definition of type t/1
Line 2, characters 2-11:
Definition of type t/2
|}]
module K = struct
@ -93,13 +85,9 @@ Error: Signature mismatch:
At position module A(X : <here>) : ...
Modules do not match: s/2 is not included in s/1
Line 5, characters 6-19:
module type s
^^^^^^^^^^^^^
Definition of module type s/1
Line 2, characters 2-15:
module type s
^^^^^^^^^^^^^
Definition of module type s/2
Definition of module type s/1
Line 2, characters 2-15:
Definition of module type s/2
|}]
module L = struct
@ -127,13 +115,9 @@ Error: Signature mismatch:
type t = A of T/2.t
The types for field A are not equal.
Line 5, characters 6-34:
module T = struct type t end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module T/1
Line 2, characters 2-30:
module T = struct type t end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module T/2
Definition of module T/1
Line 2, characters 2-30:
Definition of module T/2
|}]
module O = struct
@ -157,21 +141,13 @@ Error: Signature mismatch:
is not included in
val f : (module s/2) -> t/2 -> t/2
Line 5, characters 23-33:
struct module type s type t = B let f (module X:s) A = B end
^^^^^^^^^^
Definition of type t/1
Line 3, characters 2-12:
type t = A
^^^^^^^^^^
Definition of type t/2
Line 5, characters 9-22:
struct module type s type t = B let f (module X:s) A = B end
^^^^^^^^^^^^^
Definition of module type s/1
Line 2, characters 2-15:
module type s
^^^^^^^^^^^^^
Definition of module type s/2
Definition of type t/1
Line 3, characters 2-12:
Definition of type t/2
Line 5, characters 9-22:
Definition of module type s/1
Line 2, characters 2-15:
Definition of module type s/2
|}]
module P = struct
@ -195,13 +171,9 @@ Error: Signature mismatch:
is not included in
val f : a/2 -> (module a) -> a/2
Line 5, characters 12-22:
= struct type a = B let f A _ = B end
^^^^^^^^^^
Definition of type a/1
Line 3, characters 2-12:
type a = A
^^^^^^^^^^
Definition of type a/2
Definition of type a/1
Line 3, characters 2-12:
Definition of type a/2
|}]
module Q = struct
@ -232,13 +204,9 @@ Error: Signature mismatch:
The first class type has no method m
The public method c cannot be hidden
Line 5, characters 4-74:
class a = object method c = let module X = struct type t end in () end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/1
Line 2, characters 2-36:
class a = object method m = () end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/2
Definition of class type a/1
Line 2, characters 2-36:
Definition of class type a/2
|}]
module R = struct
@ -267,13 +235,9 @@ Error: Signature mismatch:
class type b = a/2
The first class type has no method m
Line 5, characters 4-29:
class type a = object end
^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/1
Line 2, characters 2-42:
class type a = object method m: unit end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/2
Definition of class type a/1
Line 2, characters 2-42:
Definition of class type a/2
|}]
module S = struct
@ -337,13 +301,9 @@ Error: Signature mismatch:
The method m has type t/2 but is expected to have type t/1
Type t/2 is not compatible with type t/1 = K.t
Line 12, characters 4-10:
type t
^^^^^^
Definition of type t/1
Line 9, characters 2-8:
type t
^^^^^^
Definition of type t/2
Definition of type t/1
Line 9, characters 2-8:
Definition of type t/2
|}]
;;
@ -364,11 +324,9 @@ Error: Signature mismatch:
is not included in
type a = M/2.t
Line 2, characters 14-42:
struct type t module M = struct type t end type a = M.t end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module M/1
File "_none_", line 1:
Definition of module M/2
Definition of module M/1
File "_none_", line 1:
Definition of module M/2
|}]
@ -399,21 +357,13 @@ Error: Signature mismatch:
is not included in
val f : t/1 -> t/1 -> t/1 -> t/1
Line 4, characters 0-10:
type t = D;;
^^^^^^^^^^
Definition of type t/1
Line 1, characters 0-10:
type t = A;;
^^^^^^^^^^
Definition of type t/2
Line 2, characters 0-10:
type t = B;;
^^^^^^^^^^
Definition of type t/3
Line 3, characters 0-10:
type t = C;;
^^^^^^^^^^
Definition of type t/4
Definition of type t/1
Line 1, characters 0-10:
Definition of type t/2
Line 2, characters 0-10:
Definition of type t/3
Line 3, characters 0-10:
Definition of type t/4
|}]
(** Check interaction with no-alias-deps *)

10
testsuite/tests/typing-misc/pr6634.ml
View File

@ -24,11 +24,7 @@ Error: Signature mismatch:
is not included in
type t = [ `T of t/1 ]
Line 1, characters 0-12:
type t = int
^^^^^^^^^^^^
Definition of type t/1
Line 4, characters 2-20:
type t = [`T of t]
^^^^^^^^^^^^^^^^^^
Definition of type t/2
Definition of type t/1
Line 4, characters 2-20:
Definition of type t/2
|}]

3
testsuite/tests/typing-misc/typecore_empty_polyvariant_error.compilers.reference
View File

@ -2,6 +2,5 @@ type t = [ ]
Line 1, characters 31-32:
let f: 'a. t -> 'a = function #t -> . ;;
^
Error: The type t
is not a variant type
Error: The type t is not a variant type

12
testsuite/tests/typing-misc/typecore_errors.ml
View File

@ -98,7 +98,7 @@ Line 1, characters 32-33:
let c = object val x= 0 val y = x end
^
Error: The instance variable x
cannot be accessed from the definition of another instance variable
cannot be accessed from the definition of another instance variable
|}]
@ -240,8 +240,7 @@ val f : int -> unit = <fun>
Line 3, characters 10-29:
let x = f (module struct end)
^^^^^^^^^^^^^^^^^^^
Error: This expression is packed module, but the expected type is
int
Error: This expression is packed module, but the expected type is int
|}]
@ -292,8 +291,8 @@ Line 1, characters 23-24:
let g f = f ~x:0 ~y:0; f ~y:0 ~x:0
^
Error: This function is applied to arguments
in an order different from other calls.
This is only allowed when the real type is known.
in an order different from other calls.
This is only allowed when the real type is known.
|}]
(** Inlined record *)
@ -368,8 +367,7 @@ type t = []
Line 2, characters 18-19:
let f = function #t -> ()
^
Error: The type t
is not a variant type
Error: The type t is not a variant type
|}]
let f {x;x=y;x=z} = x

49
testsuite/tests/typing-misc/unique_names_in_unification.ml
View File

@ -16,14 +16,10 @@ Line 5, characters 27-28:
^
Error: This expression has type t/2 but an expression was expected of type
t/1
Line 4, characters 2-12:
type t = B
^^^^^^^^^^
Definition of type t/1
Line 1, characters 0-10:
type t = A
^^^^^^^^^^
Definition of type t/2
Line 4, characters 2-12:
Definition of type t/1
Line 1, characters 0-10:
Definition of type t/2
|}]
module M = struct type t = B end
@ -43,15 +39,10 @@ Line 7, characters 34-35:
^
Error: This expression has type M/2.t but an expression was expected of type
M/1.t
Line 4, characters 2-41:
..module M = struct
type t = C
end
Definition of module M/1
Line 1, characters 0-32:
module M = struct type t = B end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module M/2
Line 4, characters 2-41:
Definition of module M/1
Line 1, characters 0-32:
Definition of module M/2
|}]
type t = D
@ -65,14 +56,10 @@ Line 2, characters 25-26:
^
Error: This expression has type t/1 but an expression was expected of type
t/2
Line 1, characters 0-10:
type t = A
^^^^^^^^^^
Definition of type t/1
Line 1, characters 0-10:
type t = D
^^^^^^^^^^
Definition of type t/2
Line 1, characters 0-10:
Definition of type t/1
Line 1, characters 0-10:
Definition of type t/2
|}]
type ttt
@ -93,12 +80,8 @@ Line 2, characters 32-33:
^
Error: This expression has type ttt/2 but an expression was expected of type
ttt/1
Line 1, characters 0-26:
type nonrec ttt = X of ttt
^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of type ttt/1
Line 2, characters 0-30:
type ttt = A of ttt | B of uuu
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of type ttt/2
Line 1, characters 0-26:
Definition of type ttt/1
Line 2, characters 0-30:
Definition of type ttt/2
|}]

4
testsuite/tests/typing-missing-cmi/test.compilers.reference
View File

@ -1,5 +1,5 @@
File "main.ml", line 1, characters 14-17:
Error: This expression has type M.b but an expression was expected of type
M.a
M.b is abstract because no corresponding cmi file was found in path.
M.a is abstract because no corresponding cmi file was found in path.
M.b is abstract because no corresponding cmi file was found in path.
M.a is abstract because no corresponding cmi file was found in path.

1
testsuite/tests/typing-modules/aliases.ml
View File

@ -661,7 +661,6 @@ module rec Bad : A = Bad;;
[%%expect{|
module type Alias = sig module N : sig end module M = N end
module F : functor (X : sig end) -> sig type t end
Line 1:
Error: Module type declarations do not match:
module type A = sig module M = F(List) end
does not match

1
testsuite/tests/typing-modules/pr7726.ml
View File

@ -110,7 +110,6 @@ M.f 5;;
module Foo :
functor (F : T -> T) -> sig val f : Fix(F).Fixed.t -> Fix(F).Fixed.t end
module M : sig val f : Fix(Id).Fixed.t -> Fix(Id).Fixed.t end
Line 1:
Error: In the signature of Fix(Id):
The definition of Fixed.t contains a cycle:
Id(Fixed).t

3
testsuite/tests/typing-poly/poly.ml
View File

@ -1597,8 +1597,7 @@ and g = <a:t>
Line 1, characters 10-11:
type t = <g>
^
Error: The type constructor g
is not yet completely defined
Error: The type constructor g is not yet completely defined
|}]
type t = int

14
testsuite/tests/typing-unboxed/test.ml
View File

@ -57,7 +57,7 @@ Line 11, characters 2-71:
external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: [@The native code version of the primitive is mandatory
when attributes [@untagged] or [@unboxed] are present.
when attributes [@untagged] or [@unboxed] are present.
|}]
module Old_style_warning = struct
@ -355,7 +355,7 @@ Line 1, characters 0-45:
external o : (float[@unboxed]) -> float = "o";;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: [@The native code version of the primitive is mandatory
when attributes [@untagged] or [@unboxed] are present.
when attributes [@untagged] or [@unboxed] are present.
|}]
external p : float -> (float[@unboxed]) = "p";;
[%%expect{|
@ -363,7 +363,7 @@ Line 1, characters 0-45:
external p : float -> (float[@unboxed]) = "p";;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: [@The native code version of the primitive is mandatory
when attributes [@untagged] or [@unboxed] are present.
when attributes [@untagged] or [@unboxed] are present.
|}]
external q : (int[@untagged]) -> float = "q";;
[%%expect{|
@ -371,7 +371,7 @@ Line 1, characters 0-44:
external q : (int[@untagged]) -> float = "q";;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: [@The native code version of the primitive is mandatory
when attributes [@untagged] or [@unboxed] are present.
when attributes [@untagged] or [@unboxed] are present.
|}]
external r : int -> (int[@untagged]) = "r";;
[%%expect{|
@ -379,7 +379,7 @@ Line 1, characters 0-42:
external r : int -> (int[@untagged]) = "r";;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: [@The native code version of the primitive is mandatory
when attributes [@untagged] or [@unboxed] are present.
when attributes [@untagged] or [@unboxed] are present.
|}]
external s : int -> int = "s" [@@untagged];;
[%%expect{|
@ -387,7 +387,7 @@ Line 1, characters 0-42:
external s : int -> int = "s" [@@untagged];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: [@The native code version of the primitive is mandatory
when attributes [@untagged] or [@unboxed] are present.
when attributes [@untagged] or [@unboxed] are present.
|}]
external t : float -> float = "t" [@@unboxed];;
[%%expect{|
@ -395,7 +395,7 @@ Line 1, characters 0-45:
external t : float -> float = "t" [@@unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: [@The native code version of the primitive is mandatory
when attributes [@untagged] or [@unboxed] are present.
when attributes [@untagged] or [@unboxed] are present.
|}]
(* PR#7424 *)

88
testsuite/tests/warnings/deprecated_module_assigment.compilers.reference
View File

@ -1,72 +1,72 @@
File "deprecated_module_assigment.ml", line 17, characters 33-34:
Warning 3: deprecated: x
DEPRECATED
File "deprecated_module_assigment.ml", line 12, characters 2-41:
Definition
File "deprecated_module_assigment.ml", line 17, characters 15-26:
Expected signature
File "deprecated_module_assigment.ml", line 12, characters 2-41:
Definition
File "deprecated_module_assigment.ml", line 17, characters 15-26:
Expected signature
File "deprecated_module_assigment.ml", line 23, characters 13-14:
Warning 3: deprecated: x
DEPRECATED
File "deprecated_module_assigment.ml", line 12, characters 2-41:
Definition
File "deprecated_module_assigment.ml", line 21, characters 17-28:
Expected signature
File "deprecated_module_assigment.ml", line 12, characters 2-41:
Definition
File "deprecated_module_assigment.ml", line 21, characters 17-28:
Expected signature
File "deprecated_module_assigment.ml", line 33, characters 39-78:
Warning 3: deprecated: A
File "deprecated_module_assigment.ml", line 33, characters 55-70:
Definition
File "deprecated_module_assigment.ml", line 33, characters 27-28:
Expected signature
File "deprecated_module_assigment.ml", line 33, characters 55-70:
Definition
File "deprecated_module_assigment.ml", line 33, characters 27-28:
Expected signature
File "deprecated_module_assigment.ml", line 37, characters 2-20:
Warning 3: deprecated: A
File "deprecated_module_assigment.ml", line 36, characters 11-26:
Definition
File "deprecated_module_assigment.ml", line 37, characters 15-16:
Expected signature
File "deprecated_module_assigment.ml", line 36, characters 11-26:
Definition
File "deprecated_module_assigment.ml", line 37, characters 15-16:
Expected signature
File "deprecated_module_assigment.ml", line 45, characters 0-58:
Warning 3: deprecated: mutating field x
File "deprecated_module_assigment.ml", line 45, characters 17-53:
Definition
File "deprecated_module_assigment.ml", line 44, characters 14-28:
Expected signature
File "deprecated_module_assigment.ml", line 45, characters 17-53:
Definition
File "deprecated_module_assigment.ml", line 44, characters 14-28:
Expected signature
File "deprecated_module_assigment.ml", line 49, characters 2-31:
Warning 3: deprecated: mutating field x
File "deprecated_module_assigment.ml", line 48, characters 12-48:
Definition
File "deprecated_module_assigment.ml", line 49, characters 16-30:
Expected signature
File "deprecated_module_assigment.ml", line 48, characters 12-48:
Definition
File "deprecated_module_assigment.ml", line 49, characters 16-30:
Expected signature
File "deprecated_module_assigment.ml", line 54, characters 37-75:
Warning 3: deprecated: t
File "deprecated_module_assigment.ml", line 54, characters 44-71:
Definition
File "deprecated_module_assigment.ml", line 54, characters 18-30:
Expected signature
File "deprecated_module_assigment.ml", line 54, characters 44-71:
Definition
File "deprecated_module_assigment.ml", line 54, characters 18-30:
Expected signature
File "deprecated_module_assigment.ml", line 60, characters 0-52:
Warning 3: deprecated: c
FOO
File "deprecated_module_assigment.ml", line 60, characters 7-48:
Definition
File "deprecated_module_assigment.ml", line 59, characters 4-24:
Expected signature
File "deprecated_module_assigment.ml", line 60, characters 7-48:
Definition
File "deprecated_module_assigment.ml", line 59, characters 4-24:
Expected signature
File "deprecated_module_assigment.ml", line 64, characters 0-57:
Warning 3: deprecated: c
FOO
File "deprecated_module_assigment.ml", line 64, characters 7-53:
Definition
File "deprecated_module_assigment.ml", line 63, characters 4-29:
Expected signature
File "deprecated_module_assigment.ml", line 64, characters 7-53:
Definition
File "deprecated_module_assigment.ml", line 63, characters 4-29:
Expected signature
File "deprecated_module_assigment.ml", line 71, characters 0-55:
Warning 3: deprecated: S
FOO
File "deprecated_module_assigment.ml", line 71, characters 7-51:
Definition
File "deprecated_module_assigment.ml", line 70, characters 4-27:
Expected signature
File "deprecated_module_assigment.ml", line 71, characters 7-51:
Definition
File "deprecated_module_assigment.ml", line 70, characters 4-27:
Expected signature
File "deprecated_module_assigment.ml", line 82, characters 0-53:
Warning 3: deprecated: M
FOO
File "deprecated_module_assigment.ml", line 82, characters 7-49:
Definition
File "deprecated_module_assigment.ml", line 81, characters 4-22:
Expected signature
File "deprecated_module_assigment.ml", line 82, characters 7-49:
Definition
File "deprecated_module_assigment.ml", line 81, characters 4-22:
Expected signature

20
testsuite/tools/expect_test.ml
View File

@ -62,8 +62,7 @@ let match_expect_extension (ext : Parsetree.extension) =
match ext with
| ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) ->
let invalid_payload () =
Location.raise_errorf ~loc:extid_loc
"invalid [%%%%expect payload]"
Location.raise_errorf ~loc:extid_loc "invalid [%%%%expect payload]"
in
let string_constant (e : Parsetree.expression) =
match e.pexp_desc with
@ -130,16 +129,25 @@ let split_chunks phrases =
loop phrases [] []
module Compiler_messages = struct
let print_loc ppf (loc : Location.t) =
Format.fprintf ppf "%a:@." Location.print_loc loc;
let highlight ppf locs =
match !Location.input_lexbuf with
| None -> ()
| Some lexbuf -> Location.show_code_at_location ppf lexbuf [loc]
| Some lb -> Location.highlight_dumb ~print_chars:true lb ppf locs
let expect_printer () =
let dumb_toplevel_printer = Location.toplevel_printer ~highlight in
let pp_main_loc _self (report: Location.report) ppf _ =
(* We want to highlight locations even coming from a file, but the default
toplevel printer will only highlight locations from the toplevel. *)
let sub_locs = List.map (fun { Location.loc; _ } -> loc) report.sub in
highlight ppf (report.main.loc :: sub_locs)
in
{ dumb_toplevel_printer with pp_main_loc }
let capture ppf ~f =
Misc.protect_refs
[ R (Location.formatter_for_warnings , ppf)
; R (Location.printer , print_loc)
; R (Location.report_printer , expect_printer)
]
f
end

28
tools/caml_tex.ml
View File

@ -132,13 +132,25 @@ module Toplevel = struct
if startchar >= 0 then
locs := (startchar, endchar) :: !locs
(** Record the main location instead of printing it *)
let printer_register_locs =
{ Location.batch_mode_printer with
pp_main_loc = (fun _ _ _ loc -> register_loc loc) }
(** Capture warnings and keep them in a list *)
let warnings = ref []
let print_warning loc _ppf w =
if Warnings.report w <> `Inactive then register_loc loc;
Location.default_warning_printer loc (snd warning_fmt) w;
let w = flush_fmt warning_fmt in
warnings := w :: !warnings
let report_printer =
(* Extend [printer_register_locs] *)
let pp self ppf report =
match report.Location.kind with
| Location.Report_warning _ | Location.Report_warning_as_error _ ->
printer_register_locs.pp self (snd warning_fmt) report;
let w = flush_fmt warning_fmt in
warnings := w :: !warnings
| _ ->
printer_register_locs.pp self ppf report
in
{ printer_register_locs with pp }
let fatal ic oc fmt =
Format.kfprintf
@ -146,14 +158,10 @@ module Toplevel = struct
self_error_fmt ("@[<hov 2> Error " ^^ fmt)
let init () =
Location.printer := (fun _ _ -> ());
Location.warning_printer := print_warning;
Location.report_printer := (fun () -> report_printer);
Clflags.color := Some Misc.Color.Never;
Clflags.no_std_include := true;
Compenv.last_include_dirs := [Filename.concat !repo_root "stdlib"];
Location.error_reporter :=
(fun _ e -> register_loc e.loc;
Location.default_error_reporter (snd error_fmt) e);
Compmisc.init_path false;
try
Toploop.initialize_toplevel_env ();

4
toplevel/opttoploop.ml
View File

@ -155,8 +155,8 @@ let remove_printer = Printer.remove_printer
let parse_toplevel_phrase = ref Parse.toplevel_phrase
let parse_use_file = ref Parse.use_file
let print_location = Location.print_error (* FIXME change back to print *)
let print_error = Location.print_error
let print_location = Location.print_loc
let print_error = Location.print_report
let print_warning = Location.print_warning
let input_name = Location.input_name

2
toplevel/opttoploop.mli
View File

@ -92,7 +92,7 @@ val max_printer_steps: int ref
val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref
val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref
val print_location : formatter -> Location.t -> unit
val print_error : formatter -> Location.t -> unit
val print_error : formatter -> Location.error -> unit
val print_warning : Location.t -> formatter -> Warnings.t -> unit
val input_name : string ref

4
toplevel/toploop.ml
View File

@ -116,8 +116,8 @@ let remove_printer = Printer.remove_printer
let parse_toplevel_phrase = ref Parse.toplevel_phrase
let parse_use_file = ref Parse.use_file
let print_location = Location.print_error (* FIXME change back to print *)
let print_error = Location.print_error
let print_location = Location.print_loc
let print_error = Location.print_report
let print_warning = Location.print_warning
let input_name = Location.input_name

2
toplevel/toploop.mli
View File

@ -113,7 +113,7 @@ val max_printer_steps: int ref
val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref
val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref
val print_location : formatter -> Location.t -> unit
val print_error : formatter -> Location.t -> unit
val print_error : formatter -> Location.error -> unit
val print_warning : Location.t -> formatter -> Warnings.t -> unit
val input_name : string ref

2
typing/env.ml
View File

@ -2389,7 +2389,7 @@ let () =
| Error (Missing_module (loc, _, _)
| Illegal_value_name (loc, _)
as err) when loc <> Location.none ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

2
typing/primitive.ml
View File

@ -217,7 +217,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| _ ->
None
)

4
typing/printtyp.ml
View File

@ -131,8 +131,8 @@ module Conflicts = struct
M.add name { kind = namespace; location; name } !explanations
let pp_explanation ppf r=
Format.fprintf ppf "@[<v 2>%aDefinition of %s %s@]"
Location.print r.location (Namespace.show r.kind) r.name
Format.fprintf ppf "@[<v 2>%a:@,Definition of %s %s@]"
Location.print_loc r.location (Namespace.show r.kind) r.name
let pp ppf l =
Format.fprintf ppf "@[<v>%a@]" (Format.pp_print_list pp_explanation) l

2
typing/typeclass.ml
View File

@ -2014,7 +2014,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
Some (Location.error_of_printer ~loc (report_error env) err)
| Error_forward err ->
Some err
| _ ->

2
typing/typecore.ml
View File

@ -4840,7 +4840,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
Some (Location.error_of_printer ~loc (report_error env) err)
| Error_forward err ->
Some err
| _ ->

2
typing/typedecl.ml
View File

@ -2187,7 +2187,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
Some (Location.error_of_printer ~loc report_error err)
| _ ->
None
)

2
typing/typemod.ml
View File

@ -2353,7 +2353,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
Some (Location.error_of_printer ~loc (report_error env) err)
| Error_forward err ->
Some err
| _ ->

2
typing/typetexp.ml
View File

@ -1042,7 +1042,7 @@ let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
Some (Location.error_of_printer ~loc (report_error env) err)
| Error_forward err ->
Some err
| _ ->

3
utils/warnings.ml
View File

@ -540,10 +540,11 @@ let message = function
let sub_locs = function
| Deprecated (_, def, use) ->
[
if not def.loc_ghost && not use.loc_ghost then [
def, "Definition";
use, "Expected signature";
]
else []
| _ -> []
let nerrors = ref 0;;