Skip to content

Commit 173989a

Browse files
cristianoccristianoc
committed
Give error when uncurried application tries to use label from result type.
1 parent 26a098d commit 173989a

File tree

6 files changed

+94
-60
lines changed

6 files changed

+94
-60
lines changed

‎jscomp/build_tests/super_errors/expected/uncurried_wrong_label.res.expected

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
2+
We've found a bug for you!
3+
/.../fixtures/uncurried_wrong_label.res:3:18
4+
5+
1 │ let foo = (. ~x) => { let _ = (); (~y) => x+y }
6+
2 │ // This looks too far into the return type
7+
3 │ let d = foo(. ~y=3)
8+
4 │
9+
10+
The function applied to this argument has type (. ~x: int, ~y: int) => int
11+
This argument cannot be applied with label ~y

‎jscomp/build_tests/super_errors/fixtures/uncurried_wrong_label.res

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
let foo = (. ~x) => { let _ = (); (~y) => x+y }
2+
// This looks too far into the return type
3+
let d = foo(. ~y=3)

‎jscomp/ml/typecore.ml

Lines changed: 20 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -2021,17 +2021,17 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
20212021
end_def ();
20222022
unify_var env (newvar()) funct.exp_type;
20232023

2024-
let mk_exp exp_desc exp_type =
2024+
let mk_exp ?(loc=Location.none) exp_desc exp_type =
20252025
{ exp_desc;
2026-
exp_loc = Location.none; exp_extra = [];
2026+
exp_loc = loc; exp_extra = [];
20272027
exp_type;
20282028
exp_attributes = [];
20292029
exp_env = env } in
20302030
let apply_internal name e =
20312031
let lid:Longident.t = Ldot (Ldot (Lident "Js", "Internal"), name) in
20322032
let (path, desc) = Env.lookup_value lid env in
20332033
let id = mk_exp (Texp_ident(path, {txt=lid; loc=Location.none}, desc)) desc.val_type in
2034-
mk_exp (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in
2034+
mk_exp ~loc:e.exp_loc (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in
20352035

20362036
let mk_apply funct args =
20372037
rue {
@@ -2999,8 +2999,8 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
29992999
if List.length sargs > arity then
30003000
raise(Error(funct.exp_loc, env,
30013001
Uncurried_arity_mismatch (t, arity, List.length sargs, false)));
3002-
t1
3003-
| None -> t in
3002+
t1, arity
3003+
| None -> t, max_int in
30043004
let update_uncurried_arity ~nargs t newT =
30053005
match has_uncurried_type t with
30063006
| Some (arity, _) ->
@@ -3016,7 +3016,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
30163016
(fully_applied, newT)
30173017
| _ -> (false, newT)
30183018
in
3019-
let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
3019+
let rec type_unknown_args max_arity (args : lazy_args) omitted ty_fun (syntax_args : sargs)
30203020
: targs * _ =
30213021
match syntax_args with
30223022
| [] ->
@@ -3028,22 +3028,27 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
30283028
| (l1, sarg1) :: sargl ->
30293029
let (ty1, ty2) =
30303030
let ty_fun = expand_head env ty_fun in
3031+
let arity_ok = List.length args < max_arity in
30313032
match ty_fun.desc with
3032-
Tvar _ ->
3033+
Tvar _ ->
30333034
let t1 = newvar () and t2 = newvar () in
30343035
if ty_fun.level >= t1.level && not_identity funct.exp_desc then
30353036
Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
30363037
unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
30373038
(t1, t2)
3038-
| Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1
3039+
| Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1 && arity_ok
30393040
->
3041+
if List.length args >= max_arity then assert false;
30403042
(t1, t2)
30413043
| td ->
30423044
let ty_fun =
30433045
match td with Tarrow _ -> newty td | _ -> ty_fun in
30443046
let ty_res = result_type (omitted @ !ignored) ty_fun in
30453047
match ty_res.desc with
30463048
Tarrow _ ->
3049+
if not arity_ok then
3050+
raise (Error(sarg1.pexp_loc, env,
3051+
Apply_wrong_label(l1, funct.exp_type))) else
30473052
if (not (has_label l1 ty_fun)) then
30483053
raise (Error(sarg1.pexp_loc, env,
30493054
Apply_wrong_label(l1, ty_res)))
@@ -3060,13 +3065,13 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
30603065
unify_exp env arg1 (type_option(newvar()));
30613066
arg1
30623067
in
3063-
type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl
3068+
type_unknown_args max_arity ((l1, Some arg1) :: args) omitted ty2 sargl
30643069
in
3065-
let rec type_args args omitted ~ty_fun ty_fun0 ~(sargs : sargs) =
3070+
let rec type_args max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) =
30663071
match expand_head env ty_fun, expand_head env ty_fun0 with
30673072
{desc=Tarrow (l, ty, ty_fun, com); level=lv} ,
30683073
{desc=Tarrow (_, ty0, ty_fun0, _)}
3069-
when (sargs <> [] ) && commu_repr com = Cok ->
3074+
when (sargs <> [] ) && commu_repr com = Cok && List.length args < max_arity ->
30703075
let name = label_name l
30713076
and optional = is_optional l in
30723077
let sargs, omitted, arg =
@@ -3091,9 +3096,9 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
30913096
(extract_option_type env ty)
30923097
(extract_option_type env ty0))))
30933098
in
3094-
type_args ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs
3099+
type_args max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs
30953100
| _ ->
3096-
type_unknown_args args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
3101+
type_unknown_args max_arity args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
30973102
in
30983103
let () =
30993104
let ls, tvar = list_labels env funct.exp_type in
@@ -3126,8 +3131,8 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
31263131
([Nolabel, Some exp], ty_res, false)
31273132
| _ ->
31283133
if uncurried then force_uncurried_type funct;
3129-
let ty = extract_uncurried_type funct.exp_type in
3130-
let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
3134+
let ty, max_arity = extract_uncurried_type funct.exp_type in
3135+
let targs, ret_t = type_args max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs in
31313136
let fully_applied, ret_t =
31323137
update_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in
31333138
targs, ret_t, fully_applied

‎lib/4.06.1/unstable/js_compiler.ml

Lines changed: 20 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -42751,17 +42751,17 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
4275142751
end_def ();
4275242752
unify_var env (newvar()) funct.exp_type;
4275342753

42754-
let mk_exp exp_desc exp_type =
42754+
let mk_exp ?(loc=Location.none) exp_desc exp_type =
4275542755
{ exp_desc;
42756-
exp_loc = Location.none; exp_extra = [];
42756+
exp_loc = loc; exp_extra = [];
4275742757
exp_type;
4275842758
exp_attributes = [];
4275942759
exp_env = env } in
4276042760
let apply_internal name e =
4276142761
let lid:Longident.t = Ldot (Ldot (Lident "Js", "Internal"), name) in
4276242762
let (path, desc) = Env.lookup_value lid env in
4276342763
let id = mk_exp (Texp_ident(path, {txt=lid; loc=Location.none}, desc)) desc.val_type in
42764-
mk_exp (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in
42764+
mk_exp ~loc:e.exp_loc (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in
4276542765

4276642766
let mk_apply funct args =
4276742767
rue {
@@ -43729,8 +43729,8 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4372943729
if List.length sargs > arity then
4373043730
raise(Error(funct.exp_loc, env,
4373143731
Uncurried_arity_mismatch (t, arity, List.length sargs, false)));
43732-
t1
43733-
| None -> t in
43732+
t1, arity
43733+
| None -> t, max_int in
4373443734
let update_uncurried_arity ~nargs t newT =
4373543735
match has_uncurried_type t with
4373643736
| Some (arity, _) ->
@@ -43746,7 +43746,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4374643746
(fully_applied, newT)
4374743747
| _ -> (false, newT)
4374843748
in
43749-
let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
43749+
let rec type_unknown_args max_arity (args : lazy_args) omitted ty_fun (syntax_args : sargs)
4375043750
: targs * _ =
4375143751
match syntax_args with
4375243752
| [] ->
@@ -43758,22 +43758,27 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4375843758
| (l1, sarg1) :: sargl ->
4375943759
let (ty1, ty2) =
4376043760
let ty_fun = expand_head env ty_fun in
43761+
let arity_ok = List.length args < max_arity in
4376143762
match ty_fun.desc with
43762-
Tvar _ ->
43763+
Tvar _ ->
4376343764
let t1 = newvar () and t2 = newvar () in
4376443765
if ty_fun.level >= t1.level && not_identity funct.exp_desc then
4376543766
Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
4376643767
unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
4376743768
(t1, t2)
43768-
| Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1
43769+
| Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1 && arity_ok
4376943770
->
43771+
if List.length args >= max_arity then assert false;
4377043772
(t1, t2)
4377143773
| td ->
4377243774
let ty_fun =
4377343775
match td with Tarrow _ -> newty td | _ -> ty_fun in
4377443776
let ty_res = result_type (omitted @ !ignored) ty_fun in
4377543777
match ty_res.desc with
4377643778
Tarrow _ ->
43779+
if not arity_ok then
43780+
raise (Error(sarg1.pexp_loc, env,
43781+
Apply_wrong_label(l1, funct.exp_type))) else
4377743782
if (not (has_label l1 ty_fun)) then
4377843783
raise (Error(sarg1.pexp_loc, env,
4377943784
Apply_wrong_label(l1, ty_res)))
@@ -43790,13 +43795,13 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4379043795
unify_exp env arg1 (type_option(newvar()));
4379143796
arg1
4379243797
in
43793-
type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl
43798+
type_unknown_args max_arity ((l1, Some arg1) :: args) omitted ty2 sargl
4379443799
in
43795-
let rec type_args args omitted ~ty_fun ty_fun0 ~(sargs : sargs) =
43800+
let rec type_args max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) =
4379643801
match expand_head env ty_fun, expand_head env ty_fun0 with
4379743802
{desc=Tarrow (l, ty, ty_fun, com); level=lv} ,
4379843803
{desc=Tarrow (_, ty0, ty_fun0, _)}
43799-
when (sargs <> [] ) && commu_repr com = Cok ->
43804+
when (sargs <> [] ) && commu_repr com = Cok && List.length args < max_arity ->
4380043805
let name = label_name l
4380143806
and optional = is_optional l in
4380243807
let sargs, omitted, arg =
@@ -43821,9 +43826,9 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4382143826
(extract_option_type env ty)
4382243827
(extract_option_type env ty0))))
4382343828
in
43824-
type_args ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs
43829+
type_args max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs
4382543830
| _ ->
43826-
type_unknown_args args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
43831+
type_unknown_args max_arity args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
4382743832
in
4382843833
let () =
4382943834
let ls, tvar = list_labels env funct.exp_type in
@@ -43856,8 +43861,8 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4385643861
([Nolabel, Some exp], ty_res, false)
4385743862
| _ ->
4385843863
if uncurried then force_uncurried_type funct;
43859-
let ty = extract_uncurried_type funct.exp_type in
43860-
let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
43864+
let ty, max_arity = extract_uncurried_type funct.exp_type in
43865+
let targs, ret_t = type_args max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs in
4386143866
let fully_applied, ret_t =
4386243867
update_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in
4386343868
targs, ret_t, fully_applied

‎lib/4.06.1/unstable/js_playground_compiler.ml

Lines changed: 20 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -42751,17 +42751,17 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
4275142751
end_def ();
4275242752
unify_var env (newvar()) funct.exp_type;
4275342753

42754-
let mk_exp exp_desc exp_type =
42754+
let mk_exp ?(loc=Location.none) exp_desc exp_type =
4275542755
{ exp_desc;
42756-
exp_loc = Location.none; exp_extra = [];
42756+
exp_loc = loc; exp_extra = [];
4275742757
exp_type;
4275842758
exp_attributes = [];
4275942759
exp_env = env } in
4276042760
let apply_internal name e =
4276142761
let lid:Longident.t = Ldot (Ldot (Lident "Js", "Internal"), name) in
4276242762
let (path, desc) = Env.lookup_value lid env in
4276342763
let id = mk_exp (Texp_ident(path, {txt=lid; loc=Location.none}, desc)) desc.val_type in
42764-
mk_exp (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in
42764+
mk_exp ~loc:e.exp_loc (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in
4276542765

4276642766
let mk_apply funct args =
4276742767
rue {
@@ -43729,8 +43729,8 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4372943729
if List.length sargs > arity then
4373043730
raise(Error(funct.exp_loc, env,
4373143731
Uncurried_arity_mismatch (t, arity, List.length sargs, false)));
43732-
t1
43733-
| None -> t in
43732+
t1, arity
43733+
| None -> t, max_int in
4373443734
let update_uncurried_arity ~nargs t newT =
4373543735
match has_uncurried_type t with
4373643736
| Some (arity, _) ->
@@ -43746,7 +43746,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4374643746
(fully_applied, newT)
4374743747
| _ -> (false, newT)
4374843748
in
43749-
let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
43749+
let rec type_unknown_args max_arity (args : lazy_args) omitted ty_fun (syntax_args : sargs)
4375043750
: targs * _ =
4375143751
match syntax_args with
4375243752
| [] ->
@@ -43758,22 +43758,27 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4375843758
| (l1, sarg1) :: sargl ->
4375943759
let (ty1, ty2) =
4376043760
let ty_fun = expand_head env ty_fun in
43761+
let arity_ok = List.length args < max_arity in
4376143762
match ty_fun.desc with
43762-
Tvar _ ->
43763+
Tvar _ ->
4376343764
let t1 = newvar () and t2 = newvar () in
4376443765
if ty_fun.level >= t1.level && not_identity funct.exp_desc then
4376543766
Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
4376643767
unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
4376743768
(t1, t2)
43768-
| Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1
43769+
| Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1 && arity_ok
4376943770
->
43771+
if List.length args >= max_arity then assert false;
4377043772
(t1, t2)
4377143773
| td ->
4377243774
let ty_fun =
4377343775
match td with Tarrow _ -> newty td | _ -> ty_fun in
4377443776
let ty_res = result_type (omitted @ !ignored) ty_fun in
4377543777
match ty_res.desc with
4377643778
Tarrow _ ->
43779+
if not arity_ok then
43780+
raise (Error(sarg1.pexp_loc, env,
43781+
Apply_wrong_label(l1, funct.exp_type))) else
4377743782
if (not (has_label l1 ty_fun)) then
4377843783
raise (Error(sarg1.pexp_loc, env,
4377943784
Apply_wrong_label(l1, ty_res)))
@@ -43790,13 +43795,13 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4379043795
unify_exp env arg1 (type_option(newvar()));
4379143796
arg1
4379243797
in
43793-
type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl
43798+
type_unknown_args max_arity ((l1, Some arg1) :: args) omitted ty2 sargl
4379443799
in
43795-
let rec type_args args omitted ~ty_fun ty_fun0 ~(sargs : sargs) =
43800+
let rec type_args max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) =
4379643801
match expand_head env ty_fun, expand_head env ty_fun0 with
4379743802
{desc=Tarrow (l, ty, ty_fun, com); level=lv} ,
4379843803
{desc=Tarrow (_, ty0, ty_fun0, _)}
43799-
when (sargs <> [] ) && commu_repr com = Cok ->
43804+
when (sargs <> [] ) && commu_repr com = Cok && List.length args < max_arity ->
4380043805
let name = label_name l
4380143806
and optional = is_optional l in
4380243807
let sargs, omitted, arg =
@@ -43821,9 +43826,9 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4382143826
(extract_option_type env ty)
4382243827
(extract_option_type env ty0))))
4382343828
in
43824-
type_args ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs
43829+
type_args max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs
4382543830
| _ ->
43826-
type_unknown_args args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
43831+
type_unknown_args max_arity args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
4382743832
in
4382843833
let () =
4382943834
let ls, tvar = list_labels env funct.exp_type in
@@ -43856,8 +43861,8 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
4385643861
([Nolabel, Some exp], ty_res, false)
4385743862
| _ ->
4385843863
if uncurried then force_uncurried_type funct;
43859-
let ty = extract_uncurried_type funct.exp_type in
43860-
let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
43864+
let ty, max_arity = extract_uncurried_type funct.exp_type in
43865+
let targs, ret_t = type_args max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs in
4386143866
let fully_applied, ret_t =
4386243867
update_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in
4386343868
targs, ret_t, fully_applied

0 commit comments

Comments
 (0)