Improve function apply error messages

compiler/ml/typecore.ml

@@ -75,7 +75,8 @@ type error =
   | Unknown_literal of string * char
   | Illegal_letrec_pat
   | Empty_record_literal
-  | Uncurried_arity_mismatch of type_expr * int * int
+  | Uncurried_arity_mismatch of
+      type_expr * int * int * Asttypes.Noloc.arg_label list
   | Field_not_optional of string * type_expr
   | Type_params_not_supported of Longident.t
   | Field_access_on_dict_type
@@ -3466,7 +3467,10 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
              ( funct.exp_loc,
                env,
                Uncurried_arity_mismatch
-                 (funct.exp_type, arity, List.length sargs) ));
+                 ( funct.exp_type,
+                   arity,
+                   List.length sargs,
+                   sargs |> List.map (fun (a, _) -> to_noloc a) ) ));
       arity
     | None -> max_int
   in
@@ -3482,7 +3486,10 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
               ( funct.exp_loc,
                 env,
                 Uncurried_arity_mismatch
-                  (funct.exp_type, required_args + newarity, required_args) )));
+                  ( funct.exp_type,
+                    required_args + newarity,
+                    required_args,
+                    sargs |> List.map (fun (a, _) -> to_noloc a) ) )));
       let new_t =
         if fully_applied then new_t
         else
@@ -4250,17 +4257,20 @@ let report_error env ppf error =
         accepts_count
         (if accepts_count == 1 then "argument" else "arguments")
     | _ ->
-      fprintf ppf "@[<v>@[<2>This expression has type@ %a@]@ %s@]" type_expr typ
-        "It is not a function.")
+      fprintf ppf
+        "@[<v>@[<2>This can't be called, it's not a function.@]@,\
+         The function has type: %a@]"
+        type_expr typ)
   | Apply_wrong_label (l, ty) ->
-    let print_label ppf = function
-      | Noloc.Nolabel -> fprintf ppf "without label"
-      | l -> fprintf ppf "with label %s" (prefixed_label_name l)
+    let print_message ppf = function
+      | Noloc.Nolabel ->
+        fprintf ppf "The argument at this position should be labelled."
+      | l ->
+        fprintf ppf "This function does not take the argument @{<info>%s@}."
+          (prefixed_label_name l)
     in
-    fprintf ppf
-      "@[<v>@[<2>The function applied to this argument has type@ %a@]@.This \
-       argument cannot be applied %a@]"
-      type_expr ty print_label l
+    fprintf ppf "@[<v>@[<2>%a@]@,This function has type: %a@]" print_message l
+      type_expr ty
   | Label_multiply_defined {label; jsx_component_info = Some jsx_component_info}
     ->
     fprintf ppf
@@ -4410,14 +4420,116 @@ let report_error env ppf error =
     fprintf ppf
       "Empty record literal {} should be type annotated or used in a record \
        context."
-  | Uncurried_arity_mismatch (typ, arity, args) ->
-    fprintf ppf "@[<v>@[<2>This function has type@ %a@]" type_expr typ;
-    fprintf ppf
-      "@ @[It is applied with @{<error>%d@} argument%s but it requires \
-       @{<info>%d@}.@]@]"
-      args
-      (if args = 1 then "" else "s")
-      arity
+  | Uncurried_arity_mismatch (typ, arity, args, sargs) ->
+    (* We need:
+    - Any arg that's required but isn't passed 
+    - Any arg that is passed but isn't in the fn definition (optional or labelled)
+    - Any mismatch in the number of unlabelled args (since all of them are required)  
+    *)
+    let rec collect_args ?(acc = []) typ =
+      match typ.desc with
+      | Tarrow (arg, _, next, _, _) -> collect_args ~acc:(arg :: acc) next
+      | _ -> acc
+    in
+    let args_from_type = collect_args typ in
+
+    (* Unlabelled arg counts *)
+    let args_from_type_unlabelled =
+      args_from_type
+      |> List.filter (fun arg -> arg = Noloc.Nolabel)
+      |> List.length
+    in
+    let sargs_unlabelled =
+      sargs |> List.filter (fun arg -> arg = Noloc.Nolabel) |> List.length
+    in
+    let mismatch_in_unlabelled_args =
+      args_from_type_unlabelled <> sargs_unlabelled
+    in
+
+    (* Required args that aren't passed *)
+    let required_args =
+      args_from_type
+      |> List.filter_map (fun arg ->
+             match arg with
+             | Noloc.Labelled n -> Some n
+             | Optional _ | Nolabel -> None)
+    in
+    let passed_named_args =
+      sargs
+      |> List.filter_map (fun arg ->
+             match arg with
+             | Noloc.Labelled n | Optional n -> Some n
+             | Nolabel -> None)
+    in
+    let missing_required_args =
+      required_args
+      |> List.filter (fun arg -> not (List.mem arg passed_named_args))
+    in
+
+    (* Passed args that the fn does not take *)
+    let named_args_of_fn_type =
+      args_from_type
+      |> List.filter_map (fun arg ->
+             match arg with
+             | Noloc.Labelled n | Optional n -> Some n
+             | Nolabel -> None)
+    in
+    let superfluous_args =
+      passed_named_args
+      |> List.filter (fun arg -> not (List.mem arg named_args_of_fn_type))
+    in
+
+    let is_fallback =
+      List.length missing_required_args = 0
+      && List.length superfluous_args = 0
+      && mismatch_in_unlabelled_args = false
+    in
+
+    fprintf ppf "@[<v>@[<2>This function call is incorrect.@]";
+    fprintf ppf "@,The function has type:@ %a" type_expr typ;
+
+    if not is_fallback then fprintf ppf "@,";
+
+    if List.length missing_required_args > 0 then
+      fprintf ppf "@,- Missing arguments that must be provided: %s"
+        (missing_required_args
+        |> List.map (fun v -> "~" ^ v)
+        |> String.concat ", ");
+
+    if List.length superfluous_args > 0 then
+      fprintf ppf "@,- Called with arguments it does not take: %s"
+        (superfluous_args |> String.concat ", ");
+
+    let unlabelled_msg a b pos =
+      match (a, pos) with
+      | 0, `left -> "no"
+      | 0, `right -> "none"
+      | _ when a > b -> string_of_int a
+      | _ -> "just " ^ string_of_int a
+    in
+
+    if mismatch_in_unlabelled_args then
+      fprintf ppf
+        "@,\
+         - The function takes @{<info>%s@} unlabelled argument%s, but is \
+         called with @{<error>%s@}"
+        (unlabelled_msg args_from_type_unlabelled sargs_unlabelled `left)
+        (if args_from_type_unlabelled = 1 then "" else "s")
+        (unlabelled_msg sargs_unlabelled args_from_type_unlabelled `right);
+
+    (* Print fallback if nothing above matched *)
+    if is_fallback then
+      fprintf ppf
+        "@,\
+         @,\
+         It is called with @{<error>%d@} argument%s but requires%s \
+         @{<info>%d@}."
+        args
+        (if args > arity then " just" else "")
+        (if args = 1 then "" else "s")
+        arity;
+
+    fprintf ppf "@]"
   | Field_not_optional (name, typ) ->
     fprintf ppf "Field @{<info>%s@} is not optional in type %a. Use without ?"
       name type_expr typ

compiler/ml/typecore.mli

@@ -100,7 +100,8 @@ type error =
   | Unknown_literal of string * char
   | Illegal_letrec_pat
   | Empty_record_literal
-  | Uncurried_arity_mismatch of type_expr * int * int
+  | Uncurried_arity_mismatch of
+      type_expr * int * int * Asttypes.Noloc.arg_label list
   | Field_not_optional of string * type_expr
   | Type_params_not_supported of Longident.t
   | Field_access_on_dict_type

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

@@ -6,5 +6,8 @@
   2 │ let makeVariables = makeVar(~f=f => f)
   3 │ 
 
-  This function has type (~f: 'a => 'a, unit) => int
-  It is applied with 1 argument but it requires 2.
+  This function call is incorrect.
+  The function has type:
+  (~f: 'a => 'a, unit) => int
+
+  - The function takes 1 unlabelled argument, but is called with none

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

@@ -6,5 +6,8 @@
   2 │ let makeVariables = makeVar(1, 2, 3)
   3 │ 
 
-  This function has type ('a, unit) => int
-  It is applied with 3 arguments but it requires 2.
+  This function call is incorrect.
+  The function has type:
+  ('a, unit) => int
+
+  - The function takes just 2 unlabelled arguments, but is called with 3

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

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/arity_mismatch4.res:2:21-27
+
+  1 │ let makeVar = (~f) => 34
+  2 │ let makeVariables = makeVar(1, ~f=f => f)
+  3 │ 
+
+  This function call is incorrect.
+  The function has type:
+  (~f: 'a) => int
+
+  - The function takes no unlabelled arguments, but is called with 1

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

@@ -19,5 +19,5 @@
   4 │ let err = f(1, 2)
   5 │ 
 
-  The function applied to this argument has type ('a, ~def: int=?) => 'b
-This argument cannot be applied without label
+  The argument at this position should be labelled.
+  This function has type: ('a, ~def: int=?) => 'b

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

@@ -19,6 +19,5 @@
   7 │ let err = r("", ~initialValue=2)
   8 │ 
 
-  The function applied to this argument has type
-    (string, ~wrongLabelName: int=?) => 'a
-This argument cannot be applied with label ~initialValue
+  This function does not take the argument ~initialValue.
+  This function has type: (string, ~wrongLabelName: int=?) => 'a

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

@@ -8,5 +8,8 @@
   4 │ }
   5 │ 
 
-  This function has type (int, int) => unit
-  It is applied with 1 argument but it requires 2.
+  This function call is incorrect.
+  The function has type:
+  (int, int) => unit
+
+  It is called with 1 argument but requires 2.

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

@@ -7,5 +7,5 @@
   3 │ let _ = f("")
   4 │ 
 
-  The function applied to this argument has type (~a: string) => string
-This argument cannot be applied without label
+  The argument at this position should be labelled.
+  This function has type: (~a: string) => string

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

@@ -7,6 +7,5 @@
   3 │ let _ = f("", "")
   4 │ 
 
-  The function applied to this argument has type
-    (~a: string, ~b: string) => string
-This argument cannot be applied without label
+  The argument at this position should be labelled.
+  This function has type: (~a: string, ~b: string) => string

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

@@ -6,5 +6,8 @@
   2 │ let y = x(~a=2) + 2
   3 │ 
 
-  This function has type (~a: int, ~b: int) => int
-  It is applied with 1 argument but it requires 2.
+  This function call is incorrect.
+  The function has type:
+  (~a: int, ~b: int) => int
+
+  - Missing arguments that must be provided: ~b

tests/build_tests/super_errors/expected/moreArguments2.res.expected

@@ -6,5 +6,8 @@
   2 │ let y = x(2) + 2
   3 │ 
 
-  This function has type (int, int) => int
-  It is applied with 1 argument but it requires 2.
+  This function call is incorrect.
+  The function has type:
+  (int, int) => int
+
+  - The function takes 2 unlabelled arguments, but is called with just 1

tests/build_tests/super_errors/expected/moreArguments3.res.expected

@@ -6,5 +6,8 @@
   2 │ let y = x(2) + 2
   3 │ 
 
-  This function has type (int, int, 'a, 'b) => int
-  It is applied with 1 argument but it requires 4.
+  This function call is incorrect.
+  The function has type:
+  (int, int, 'a, 'b) => int
+
+  - The function takes 4 unlabelled arguments, but is called with just 1

tests/build_tests/super_errors/expected/moreArguments4.res.expected

@@ -6,5 +6,8 @@
   2 │ let y = x(2) + 2
   3 │ 
 
-  This function has type (int, ~b: int, ~c: 'a, ~d: 'b) => int
-  It is applied with 1 argument but it requires 4.
+  This function call is incorrect.
+  The function has type:
+  (int, ~b: int, ~c: 'a, ~d: 'b) => int
+
+  - Missing arguments that must be provided: ~d, ~c, ~b

tests/build_tests/super_errors/expected/moreArguments5.res.expected

@@ -7,5 +7,8 @@
   5 │ let y = x(2).Sub.a
   6 │ 
 
-  This function has type (int, 'a, 'b, 'c) => Sub.a
-  It is applied with 1 argument but it requires 4.
+  This function call is incorrect.
+  The function has type:
+  (int, 'a, 'b, 'c) => Sub.a
+
+  - The function takes 4 unlabelled arguments, but is called with just 1

tests/build_tests/super_errors/expected/non_function_uncurried_apply.res.expected

@@ -6,5 +6,5 @@
   2 │ let _ = nonfun(3)
   3 │ 
 
-  This expression has type int
-  It is not a function.
+  This can't be called, it's not a function.
+  The function has type: int

tests/build_tests/super_errors/expected/opt_args_arity.res.expected

@@ -6,5 +6,8 @@
   2 │ let x = f(42)
   3 │ 
 
-  This function has type (~a: int=?, int, int) => int
-  It is applied with 1 argument but it requires 2.
+  This function call is incorrect.
+  The function has type:
+  (~a: int=?, int, int) => int
+
+  - The function takes 2 unlabelled arguments, but is called with just 1

tests/build_tests/super_errors/expected/partial_app.res.expected

@@ -7,5 +7,8 @@
   5 │ f(1, 2)
   6 │ 
 
-  This function has type (int, int, int) => int
-  It is applied with 2 arguments but it requires 3.
+  This function call is incorrect.
+  The function has type:
+  (int, int, int) => int
+
+  - The function takes 3 unlabelled arguments, but is called with just 2