Skip to content

Commit 3312980

Browse files
zthzth
committed
rework function apply error messages
1 parent e377444 commit 3312980

22 files changed

+207
-64
lines changed

‎compiler/ml/typecore.ml‎

Lines changed: 126 additions & 19 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,17 @@ 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+
It has type: %a@]"
4263+
type_expr typ)
42554264
| Apply_wrong_label (l, ty) ->
42564265
let print_label ppf = function
4257-
| Noloc.Nolabel -> fprintf ppf "without label"
4258-
| l -> fprintf ppf "with label %s" (prefixed_label_name l)
4266+
| Noloc.Nolabel -> fprintf ppf "an unlabelled argument at this position"
4267+
| l -> fprintf ppf "the argument @{<info>%s@}" (prefixed_label_name l)
42594268
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
4269+
fprintf ppf "@[<v>@[<2>This function does not take %a.@]@,It has type: %a@]"
4270+
print_label l type_expr ty
42644271
| Label_multiply_defined {label; jsx_component_info = Some jsx_component_info}
42654272
->
42664273
fprintf ppf
@@ -4410,14 +4417,114 @@ let report_error env ppf error =
44104417
fprintf ppf
44114418
"Empty record literal {} should be type annotated or used in a record \
44124419
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
4420+
| Uncurried_arity_mismatch (typ, arity, args, sargs) ->
4421+
(* We need:
4422+
- Any arg that's required but isn't passed
4423+
- Any arg that is passed but isn't in the fn definition (optional or labelled)
4424+
- Any mismatch in the number of unlabelled args (since all of them are required)
4425+
*)
4426+
let rec collect_args ?(acc = []) typ =
4427+
match typ.desc with
4428+
| Tarrow (arg, _, next, _, _) -> collect_args ~acc:(arg :: acc) next
4429+
| _ -> acc
4430+
in
4431+
let args_from_type = collect_args typ in
4432+
4433+
(* Unlabelled arg counts *)
4434+
let args_from_type_unlabelled =
4435+
args_from_type
4436+
|> List.filter (fun arg -> arg = Noloc.Nolabel)
4437+
|> List.length
4438+
in
4439+
let sargs_unlabelled =
4440+
sargs |> List.filter (fun arg -> arg = Noloc.Nolabel) |> List.length
4441+
in
4442+
let mismatch_in_unlabelled_args =
4443+
args_from_type_unlabelled <> sargs_unlabelled
4444+
in
4445+
4446+
(* Required args that aren't passed *)
4447+
let required_args =
4448+
args_from_type
4449+
|> List.filter_map (fun arg ->
4450+
match arg with
4451+
| Noloc.Labelled n -> Some n
4452+
| Optional _ | Nolabel -> None)
4453+
in
4454+
let passed_named_args =
4455+
sargs
4456+
|> List.filter_map (fun arg ->
4457+
match arg with
4458+
| Noloc.Labelled n | Optional n -> Some n
4459+
| Nolabel -> None)
4460+
in
4461+
let missing_required_args =
4462+
required_args
4463+
|> List.filter (fun arg -> not (List.mem arg passed_named_args))
4464+
in
4465+
4466+
(* Passed args that the fn does not take *)
4467+
let named_args_of_fn_type =
4468+
args_from_type
4469+
|> List.filter_map (fun arg ->
4470+
match arg with
4471+
| Noloc.Labelled n | Optional n -> Some n
4472+
| Nolabel -> None)
4473+
in
4474+
let superfluous_args =
4475+
passed_named_args
4476+
|> List.filter (fun arg -> not (List.mem arg named_args_of_fn_type))
4477+
in
4478+
4479+
let is_fallback =
4480+
List.length missing_required_args = 0
4481+
&& List.length superfluous_args = 0
4482+
&& mismatch_in_unlabelled_args = false
4483+
in
4484+
4485+
if is_fallback then
4486+
fprintf ppf "@[<v>@[<2>This function call is incorrect.@]"
4487+
else fprintf ppf "@[<v>@[<2>This function call is incorrect:@]";
4488+
4489+
if List.length missing_required_args > 0 then
4490+
fprintf ppf "@,- Missing arguments that must be provided: %s"
4491+
(missing_required_args
4492+
|> List.map (fun v -> "~" ^ v)
4493+
|> String.concat ", ");
4494+
4495+
if List.length superfluous_args > 0 then
4496+
fprintf ppf "@,- Called with arguments it does not take: %s"
4497+
(superfluous_args |> String.concat ", ");
4498+
4499+
if mismatch_in_unlabelled_args then
4500+
fprintf ppf
4501+
"@,\
4502+
- It takes @{<info>%s@} unlabelled argument%s, but is called with \
4503+
@{<error>%s@}"
4504+
(if args_from_type_unlabelled > sargs_unlabelled then
4505+
string_of_int args_from_type_unlabelled
4506+
else "just " ^ string_of_int args_from_type_unlabelled)
4507+
(if args_from_type_unlabelled = 1 then "" else "s")
4508+
(if sargs_unlabelled > args_from_type_unlabelled then
4509+
string_of_int sargs_unlabelled
4510+
else "just " ^ string_of_int sargs_unlabelled);
4511+
4512+
if not is_fallback then fprintf ppf "@,";
4513+
fprintf ppf "@,The function has type:@ %a" type_expr typ;
4514+
4515+
(* Print fallback if nothing above matched *)
4516+
if is_fallback then
4517+
fprintf ppf
4518+
"@,\
4519+
@,\
4520+
It is called with @{<error>%d@} argument%s but requires%s \
4521+
@{<info>%d@}."
4522+
args
4523+
(if args > arity then " just" else "")
4524+
(if args = 1 then "" else "s")
4525+
arity;
4526+
4527+
fprintf ppf "@]"
44214528
| Field_not_optional (name, typ) ->
44224529
fprintf ppf "Field @{<info>%s@} is not optional in type %a. Use without ?"
44234530
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+
Can't call this function:
10+
- It takes 1 unlabelled argument, but is called with just 0
11+
12+
The function has type:
13+
(~f: 'a => 'a, unit) => int

‎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+
Can't call this function:
10+
- It takes just 2 unlabelled arguments, but is called with 3
11+
12+
The function has type:
13+
('a, unit) => int

‎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+
This function does not take an unlabelled argument at this position.
23+
It 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+
It 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+
Can't call this function.
12+
The function has type:
13+
(int, int) => unit
14+
15+
It is called with 1 argument but it 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+
This function does not take an unlabelled argument at this position.
11+
It 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+
This function does not take an unlabelled argument at this position.
11+
It has type: (~a: string, ~b: string) => string

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

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

9-
This function has type (~a: int, ~b: int) => int
10-
It is applied with 1 argument but it requires 2.
9+
Can't call this function:
10+
- Missing required arguments: ~b
11+
12+
The function has type:
13+
(~a: int, ~b: int) => int

0 commit comments

Comments
 (0)