Skip to content

Commit 3cbc730

Browse files
zthzth
authored
Improve function apply error messages (#7496)
* rework function apply error messages * update test output * adjust messages
1 parent c08a437 commit 3cbc730

24 files changed

+228
-65
lines changed

‎compiler/ml/typecore.ml

Lines changed: 132 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -75,7 +75,8 @@ type error =
7575
| Unknown_literal of string * char
7676
| Illegal_letrec_pat
7777
| Empty_record_literal
78-
| Uncurried_arity_mismatch of type_expr * int * int
78+
| Uncurried_arity_mismatch of
79+
type_expr * int * int * Asttypes.Noloc.arg_label list
7980
| Field_not_optional of string * type_expr
8081
| Type_params_not_supported of Longident.t
8182
| Field_access_on_dict_type
@@ -3466,7 +3467,10 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
34663467
( funct.exp_loc,
34673468
env,
34683469
Uncurried_arity_mismatch
3469-
(funct.exp_type, arity, List.length sargs) ));
3470+
( funct.exp_type,
3471+
arity,
3472+
List.length sargs,
3473+
sargs |> List.map (fun (a, _) -> to_noloc a) ) ));
34703474
arity
34713475
| None -> max_int
34723476
in
@@ -3482,7 +3486,10 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
34823486
( funct.exp_loc,
34833487
env,
34843488
Uncurried_arity_mismatch
3485-
(funct.exp_type, required_args + newarity, required_args) )));
3489+
( funct.exp_type,
3490+
required_args + newarity,
3491+
required_args,
3492+
sargs |> List.map (fun (a, _) -> to_noloc a) ) )));
34863493
let new_t =
34873494
if fully_applied then new_t
34883495
else
@@ -4250,17 +4257,20 @@ let report_error env ppf error =
42504257
accepts_count
42514258
(if accepts_count == 1 then "argument" else "arguments")
42524259
| _ ->
4253-
fprintf ppf "@[<v>@[<2>This expression has type@ %a@]@ %s@]" type_expr typ
4254-
"It is not a function.")
4260+
fprintf ppf
4261+
"@[<v>@[<2>This can't be called, it's not a function.@]@,\
4262+
The function has type: %a@]"
4263+
type_expr typ)
42554264
| Apply_wrong_label (l, ty) ->
4256-
let print_label ppf = function
4257-
| Noloc.Nolabel -> fprintf ppf "without label"
4258-
| l -> fprintf ppf "with label %s" (prefixed_label_name l)
4265+
let print_message ppf = function
4266+
| Noloc.Nolabel ->
4267+
fprintf ppf "The argument at this position should be labelled."
4268+
| l ->
4269+
fprintf ppf "This function does not take the argument @{<info>%s@}."
4270+
(prefixed_label_name l)
42594271
in
4260-
fprintf ppf
4261-
"@[<v>@[<2>The function applied to this argument has type@ %a@]@.This \
4262-
argument cannot be applied %a@]"
4263-
type_expr ty print_label l
4272+
fprintf ppf "@[<v>@[<2>%a@]@,This function has type: %a@]" print_message l
4273+
type_expr ty
42644274
| Label_multiply_defined {label; jsx_component_info = Some jsx_component_info}
42654275
->
42664276
fprintf ppf
@@ -4410,14 +4420,116 @@ let report_error env ppf error =
44104420
fprintf ppf
44114421
"Empty record literal {} should be type annotated or used in a record \
44124422
context."
4413-
| Uncurried_arity_mismatch (typ, arity, args) ->
4414-
fprintf ppf "@[<v>@[<2>This function has type@ %a@]" type_expr typ;
4415-
fprintf ppf
4416-
"@ @[It is applied with @{<error>%d@} argument%s but it requires \
4417-
@{<info>%d@}.@]@]"
4418-
args
4419-
(if args = 1 then "" else "s")
4420-
arity
4423+
| Uncurried_arity_mismatch (typ, arity, args, sargs) ->
4424+
(* We need:
4425+
- Any arg that's required but isn't passed
4426+
- Any arg that is passed but isn't in the fn definition (optional or labelled)
4427+
- Any mismatch in the number of unlabelled args (since all of them are required)
4428+
*)
4429+
let rec collect_args ?(acc = []) typ =
4430+
match typ.desc with
4431+
| Tarrow (arg, _, next, _, _) -> collect_args ~acc:(arg :: acc) next
4432+
| _ -> acc
4433+
in
4434+
let args_from_type = collect_args typ in
4435+
4436+
(* Unlabelled arg counts *)
4437+
let args_from_type_unlabelled =
4438+
args_from_type
4439+
|> List.filter (fun arg -> arg = Noloc.Nolabel)
4440+
|> List.length
4441+
in
4442+
let sargs_unlabelled =
4443+
sargs |> List.filter (fun arg -> arg = Noloc.Nolabel) |> List.length
4444+
in
4445+
let mismatch_in_unlabelled_args =
4446+
args_from_type_unlabelled <> sargs_unlabelled
4447+
in
4448+
4449+
(* Required args that aren't passed *)
4450+
let required_args =
4451+
args_from_type
4452+
|> List.filter_map (fun arg ->
4453+
match arg with
4454+
| Noloc.Labelled n -> Some n
4455+
| Optional _ | Nolabel -> None)
4456+
in
4457+
let passed_named_args =
4458+
sargs
4459+
|> List.filter_map (fun arg ->
4460+
match arg with
4461+
| Noloc.Labelled n | Optional n -> Some n
4462+
| Nolabel -> None)
4463+
in
4464+
let missing_required_args =
4465+
required_args
4466+
|> List.filter (fun arg -> not (List.mem arg passed_named_args))
4467+
in
4468+
4469+
(* Passed args that the fn does not take *)
4470+
let named_args_of_fn_type =
4471+
args_from_type
4472+
|> List.filter_map (fun arg ->
4473+
match arg with
4474+
| Noloc.Labelled n | Optional n -> Some n
4475+
| Nolabel -> None)
4476+
in
4477+
let superfluous_args =
4478+
passed_named_args
4479+
|> List.filter (fun arg -> not (List.mem arg named_args_of_fn_type))
4480+
in
4481+
4482+
let is_fallback =
4483+
List.length missing_required_args = 0
4484+
&& List.length superfluous_args = 0
4485+
&& mismatch_in_unlabelled_args = false
4486+
in
4487+
4488+
fprintf ppf "@[<v>@[<2>This function call is incorrect.@]";
4489+
fprintf ppf "@,The function has type:@ %a" type_expr typ;
4490+
4491+
if not is_fallback then fprintf ppf "@,";
4492+
4493+
if List.length missing_required_args > 0 then
4494+
fprintf ppf "@,- Missing arguments that must be provided: %s"
4495+
(missing_required_args
4496+
|> List.map (fun v -> "~" ^ v)
4497+
|> String.concat ", ");
4498+
4499+
if List.length superfluous_args > 0 then
4500+
fprintf ppf "@,- Called with arguments it does not take: %s"
4501+
(superfluous_args |> String.concat ", ");
4502+
4503+
let unlabelled_msg a b pos =
4504+
match (a, pos) with
4505+
| 0, `left -> "no"
4506+
| 0, `right -> "none"
4507+
| _ when a > b -> string_of_int a
4508+
| _ -> "just " ^ string_of_int a
4509+
in
4510+
4511+
if mismatch_in_unlabelled_args then
4512+
fprintf ppf
4513+
"@,\
4514+
- The function takes @{<info>%s@} unlabelled argument%s, but is \
4515+
called with @{<error>%s@}"
4516+
(unlabelled_msg args_from_type_unlabelled sargs_unlabelled `left)
4517+
(if args_from_type_unlabelled = 1 then "" else "s")
4518+
(unlabelled_msg sargs_unlabelled args_from_type_unlabelled `right);
4519+
4520+
(* Print fallback if nothing above matched *)
4521+
if is_fallback then
4522+
fprintf ppf
4523+
"@,\
4524+
@,\
4525+
It is called with @{<error>%d@} argument%s but requires%s \
4526+
@{<info>%d@}."
4527+
args
4528+
(if args > arity then " just" else "")
4529+
(if args = 1 then "" else "s")
4530+
arity;
4531+
4532+
fprintf ppf "@]"
44214533
| Field_not_optional (name, typ) ->
44224534
fprintf ppf "Field @{<info>%s@} is not optional in type %a. Use without ?"
44234535
name type_expr typ

‎compiler/ml/typecore.mli

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -100,7 +100,8 @@ type error =
100100
| Unknown_literal of string * char
101101
| Illegal_letrec_pat
102102
| Empty_record_literal
103-
| Uncurried_arity_mismatch of type_expr * int * int
103+
| Uncurried_arity_mismatch of
104+
type_expr * int * int * Asttypes.Noloc.arg_label list
104105
| Field_not_optional of string * type_expr
105106
| Type_params_not_supported of Longident.t
106107
| Field_access_on_dict_type

‎tests/build_tests/super_errors/expected/arity_mismatch.res.expected

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,5 +6,8 @@
66
2 │ let makeVariables = makeVar(~f=f => f)
77
3 │
88

9-
This function has type (~f: 'a => 'a, unit) => int
10-
It is applied with 1 argument but it requires 2.
9+
This function call is incorrect.
10+
The function has type:
11+
(~f: 'a => 'a, unit) => int
12+
13+
- The function takes 1 unlabelled argument, but is called with none

‎tests/build_tests/super_errors/expected/arity_mismatch2.res.expected

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,5 +6,8 @@
66
2 │ let makeVariables = makeVar(1, 2, 3)
77
3 │
88

9-
This function has type ('a, unit) => int
10-
It is applied with 3 arguments but it requires 2.
9+
This function call is incorrect.
10+
The function has type:
11+
('a, unit) => int
12+
13+
- The function takes just 2 unlabelled arguments, but is called with 3

‎tests/build_tests/super_errors/expected/arity_mismatch4.res.expected

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
2+
We've found a bug for you!
3+
/.../fixtures/arity_mismatch4.res:2:21-27
4+
5+
1 │ let makeVar = (~f) => 34
6+
2 │ let makeVariables = makeVar(1, ~f=f => f)
7+
3 │
8+
9+
This function call is incorrect.
10+
The function has type:
11+
(~f: 'a) => int
12+
13+
- The function takes no unlabelled arguments, but is called with 1

‎tests/build_tests/super_errors/expected/fun_return_poly1.res.expected

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,5 +19,5 @@
1919
4 │ let err = f(1, 2)
2020
5 │
2121

22-
The function applied to this argument has type ('a, ~def: int=?) => 'b
23-
This argument cannot be applied without label
22+
The argument at this position should be labelled.
23+
This function has type: ('a, ~def: int=?) => 'b

‎tests/build_tests/super_errors/expected/fun_return_poly2.res.expected

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,5 @@
1919
7 │ let err = r("", ~initialValue=2)
2020
8 │
2121

22-
The function applied to this argument has type
23-
(string, ~wrongLabelName: int=?) => 'a
24-
This argument cannot be applied with label ~initialValue
22+
This function does not take the argument ~initialValue.
23+
This function has type: (string, ~wrongLabelName: int=?) => 'a

‎tests/build_tests/super_errors/expected/method_arity_mismatch.res.expected

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,5 +8,8 @@
88
4 │ }
99
5 │
1010

11-
This function has type (int, int) => unit
12-
It is applied with 1 argument but it requires 2.
11+
This function call is incorrect.
12+
The function has type:
13+
(int, int) => unit
14+
15+
It is called with 1 argument but requires 2.

‎tests/build_tests/super_errors/expected/missing_label.res.expected

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -7,5 +7,5 @@
77
3 │ let _ = f("")
88
4 │
99

10-
The function applied to this argument has type (~a: string) => string
11-
This argument cannot be applied without label
10+
The argument at this position should be labelled.
11+
This function has type: (~a: string) => string

‎tests/build_tests/super_errors/expected/missing_labels.res.expected

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,5 @@
77
3 │ let _ = f("", "")
88
4 │
99

10-
The function applied to this argument has type
11-
(~a: string, ~b: string) => string
12-
This argument cannot be applied without label
10+
The argument at this position should be labelled.
11+
This function has type: (~a: string, ~b: string) => string

0 commit comments

Comments
 (0)