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

extract_label: return an option instead of raising

master
Thomas Refis 2020-04-01 09:56:19 +02:00
parent 6d43867011
commit b703371d7d
4 changed files with 19 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
typing/btype.ml
View File

@ -691,10 +691,12 @@ let prefixed_label_name = function
| Optional s -> "?" ^ s
let rec extract_label_aux hd l = function
[] -> raise Not_found
| [] -> None
| (l',t as p) :: ls ->
if label_name l' = l then (l', t, List.rev hd, ls)
else extract_label_aux (p::hd) l ls
if label_name l' = l then
Some (l', t, hd <> [], List.rev_append hd ls)
else
extract_label_aux (p::hd) l ls
let extract_label l ls = extract_label_aux [] l ls

7
typing/btype.mli
View File

@ -205,8 +205,11 @@ val prefixed_label_name : arg_label -> label
val extract_label :
label -> (arg_label * 'a) list ->
arg_label * 'a * (arg_label * 'a) list * (arg_label * 'a) list
(* actual label, value, before list, after list *)
(arg_label * 'a * bool * (arg_label * 'a) list) option
(* actual label,
value,
whether (label, value) was at the head of the list,
list without the extracted (label, value) *)
(**** Utilities for backtracking ****)

12
typing/typeclass.ml
View File

@ -1106,13 +1106,6 @@ and class_expr_aux cl_num val_env met_env scl =
match ty_fun, ty_fun0 with
| Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
when sargs <> [] ->
let extract_label name sargs =
match Btype.extract_label name sargs with
| exception Not_found -> None
| (l, arg, commuted, in_order) ->
if commuted <> [] then did_commute := true;
Some (l, arg, commuted @ in_order)
in
let name = Btype.label_name l
and optional = Btype.is_optional l in
let sargs, arg =
@ -1129,8 +1122,9 @@ and class_expr_aux cl_num val_env met_env scl =
else
(sargs, Some (type_argument val_env sarg0 ty ty0))
end else
match extract_label name sargs with
| Some (l', sarg0, sargs) ->
match Btype.extract_label name sargs with
| Some (l', sarg0, commuted, sargs) ->
did_commute := commuted;
if not optional && Btype.is_optional l' then
Location.prerr_warning sarg0.pexp_loc
(Warnings.Nonoptional_label

18
typing/typecore.ml
View File

@ -4260,17 +4260,6 @@ and type_application env funct sargs =
Location.prerr_warning loc w
end
in
let extract_label name sargs =
match extract_label name sargs with
| exception Not_found -> None
| (l, arg, commuted, in_order) ->
if commuted <> [] then begin
did_commute := true;
may_warn arg.pexp_loc
(Warnings.Not_principal "commuting this argument")
end;
Some (l, arg, commuted @ in_order)
in
let name = label_name l
and optional = is_optional l in
let sargs, arg =
@ -4289,7 +4278,12 @@ and type_application env funct sargs =
(sargs, Some (fun () -> type_argument env sarg0 ty ty0))
end else
match extract_label name sargs with
| Some (l', sarg0, sargs) ->
| Some (l', sarg0, commuted, sargs) ->
if commuted then begin
did_commute := true;
may_warn sarg0.pexp_loc
(Warnings.Not_principal "commuting this argument")
end;
if not optional && is_optional l' then
Location.prerr_warning sarg0.pexp_loc
(Warnings.Nonoptional_label (Printtyp.string_of_label l));