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

improve Ambiguous_name warning 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13395 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2013-03-12 14:56:15 +00:00
parent 725da3dcc9
commit 32de864a67
5 changed files with 77 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
testsuite/tests/typing-warnings/records.ml.principal.reference
View File

@ -34,7 +34,8 @@ module OK :
# Characters 55-61:
let f r = match r with {x; y} -> y + y
^^^^^^
Warning 41: this record contains fields that are ambiguous: x y.
Warning 41: these field labels belong to several types: M1.u M1.t
The first one was selected. Please disambiguate if this is wrong.
Characters 65-66:
let f r = match r with {x; y} -> y + y
^
@ -43,7 +44,8 @@ Error: This expression has type bool but an expression was expected of type
# Characters 85-91:
{x; y} -> y + y
^^^^^^
Warning 41: this record contains fields that are ambiguous: x y.
Warning 41: these field labels belong to several types: M1.u M1.t
The first one was selected. Please disambiguate if this is wrong.
Characters 85-91:
{x; y} -> y + y
^^^^^^
@ -147,7 +149,13 @@ module NM :
# Characters 8-28:
let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
^^^^^^^^^^^^^^^^^^^^
Warning 41: this record contains fields that are ambiguous: x y.
Warning 41: x belongs to several types: MN.bar MN.foo
The first one was selected. Please disambiguate if this is wrong.
Characters 8-28:
let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
^^^^^^^^^^^^^^^^^^^^
Warning 41: y belongs to several types: NM.foo NM.bar
The first one was selected. Please disambiguate if this is wrong.
Characters 19-23:
let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
^^^^

11
testsuite/tests/typing-warnings/records.ml.reference
View File

@ -30,7 +30,8 @@ module OK :
# Characters 55-61:
let f r = match r with {x; y} -> y + y
^^^^^^
Warning 41: this record contains fields that are ambiguous: x y.
Warning 41: these field labels belong to several types: M1.u M1.t
The first one was selected. Please disambiguate if this is wrong.
Characters 65-66:
let f r = match r with {x; y} -> y + y
^
@ -151,7 +152,13 @@ module NM :
# Characters 8-28:
let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
^^^^^^^^^^^^^^^^^^^^
Warning 41: this record contains fields that are ambiguous: x y.
Warning 41: x belongs to several types: MN.bar MN.foo
The first one was selected. Please disambiguate if this is wrong.
Characters 8-28:
let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
^^^^^^^^^^^^^^^^^^^^
Warning 41: y belongs to several types: NM.foo NM.bar
The first one was selected. Please disambiguate if this is wrong.
Characters 19-23:
let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
^^^^

65
typing/typecore.ml
View File

@ -577,16 +577,27 @@ end) = struct
end
| _ -> raise Not_found
let is_ambiguous env lbl others =
let rec unique eq acc = function
[] -> List.rev acc
| x :: rem ->
if List.exists (eq x) acc then unique eq acc rem
else unique eq (x :: acc) rem
let ambiguous_types env lbl others =
let tpath = get_type_path env lbl in
let different_tpath (lbl, _) =
let lbl_tpath = get_type_path env lbl in
not (compare_type_path env tpath lbl_tpath)
in
let others =
List.filter different_tpath others
in
others <> []
List.map (fun (lbl, _) -> get_type_path env lbl) others in
let tpaths = unique (compare_type_path env) [tpath] others in
match tpaths with
[_] -> []
| _ ->
let open Format in
ignore (flush_str_formatter ());
List.map
(fun p ->
fprintf str_formatter "%a" Printtyp.path p;
flush_str_formatter ())
tpaths
let disambiguate_by_type env tpath lbls =
let check_type (lbl, _) =
@ -604,9 +615,11 @@ end) = struct
[] -> unbound_name_error env lid
| (lbl, use) :: rest ->
use ();
if is_ambiguous env lbl rest then
let paths = ambiguous_types env lbl rest in
if paths <> [] then
warn lid.loc
(Warnings.Ambiguous_name ([Longident.last lid.txt], false));
(Warnings.Ambiguous_name ([Longident.last lid.txt],
paths, false));
lbl
end
| Some(tpath0, tpath, pr) ->
@ -626,9 +639,12 @@ end) = struct
| (lbl', use') :: rest ->
let lbl_tpath = get_type_path env lbl' in
if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
else if is_ambiguous env lbl' rest then
warn lid.loc
(Warnings.Ambiguous_name ([Longident.last lid.txt], false))
else
let paths = ambiguous_types env lbl rest in
if paths <> [] then
warn lid.loc
(Warnings.Ambiguous_name ([Longident.last lid.txt],
paths, false))
end;
lbl
with Not_found -> try
@ -692,7 +708,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
let open Warnings in
match msg with
| Not_principal _ -> w_pr := true
| Ambiguous_name([s], _) -> w_amb := s :: !w_amb
| Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb
| Name_out_of_scope([s], _) -> w_scope := s :: !w_scope
| _ -> Location.prerr_warning loc msg
in
@ -722,10 +738,23 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
if !w_pr then
Location.prerr_warning loc
(Warnings.Not_principal "this type-based record disambiguation");
if !w_amb <> [] && not !w_pr then
Location.prerr_warning loc
(Warnings.Ambiguous_name (List.rev !w_amb, true));
(Warnings.Not_principal "this type-based record disambiguation")
else begin
match List.rev !w_amb with
(_,types)::others as amb ->
let paths =
List.map (fun (_,lbl,_) -> Label.get_type_path env lbl) lbl_a_list in
let path = List.hd paths in
if List.for_all (compare_type_path env path) (List.tl paths) then
Location.prerr_warning loc
(Warnings.Ambiguous_name (List.map fst amb, types, true))
else
List.iter
(fun (s,l) -> Location.prerr_warning loc
(Warnings.Ambiguous_name ([s],l,false)))
amb
| _ -> ()
end;
if !w_scope <> [] then
Location.prerr_warning loc
(Warnings.Name_out_of_scope (List.rev !w_scope, true));

16
utils/warnings.ml
View File

@ -58,7 +58,7 @@ type t =
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
| Name_out_of_scope of string list * bool (* 40 *)
| Ambiguous_name of string list * bool (* 41 *)
| Ambiguous_name of string list * string list * bool (* 41 *)
| Disambiguated_name of string (* 42 *)
| Nonoptional_label of string (* 43 *)
;;
@ -316,12 +316,14 @@ let message = function
| Name_out_of_scope (slist, true) ->
"this record contains fields that are out of scope: "
^ String.concat " " slist ^ "."
| Ambiguous_name ([s], false) ->
"this use of " ^ s ^ " is ambiguous."
| Ambiguous_name (_, false) -> assert false
| Ambiguous_name (slist, true) ->
"this record contains fields that are ambiguous: "
^ String.concat " " slist ^ "."
| Ambiguous_name ([s], tl, false) ->
s ^ " belongs to several types: " ^ String.concat " " tl ^
"\nThe first one was selected. Please disambiguate if this is wrong."
| Ambiguous_name (_, _, false) -> assert false
| Ambiguous_name (slist, tl, true) ->
"these field labels belong to several types: " ^
String.concat " " tl ^
"\nThe first one was selected. Please disambiguate if this is wrong."
| Disambiguated_name s ->
"this use of " ^ s ^ " required disambiguation."
| Nonoptional_label s ->

2
utils/warnings.mli
View File

@ -53,7 +53,7 @@ type t =
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
| Name_out_of_scope of string list * bool (* 40 *)
| Ambiguous_name of string list * bool (* 41 *)
| Ambiguous_name of string list * string list * bool (* 41 *)
| Disambiguated_name of string (* 42 *)
| Nonoptional_label of string (* 43 *)
;;