Enforce function arity in type inclusion and coercion

CHANGELOG.md

@@ -26,6 +26,7 @@
 #### :bug: Bug fix
 
 - Preserve parentheses around multiplication, division, and modulo expressions used as exponents. https://github.com/rescript-lang/rescript/pull/8550
+- Enforce function arity in interface/module inclusion and type coercion. Previously a curried implementation (e.g. `int => int => int`) could satisfy an uncurried interface (`(int, int) => int`) or be coerced to it, which could miscompile calls made through the interface type. Such mismatches are now compile errors with an explanatory hint. https://github.com/rescript-lang/rescript/pull/8559
 - Preserve multibyte characters when wrapping long source lines in compiler code frames. https://github.com/rescript-lang/rescript/pull/8520
 - Fix reanalyze optional-argument diagnostics for functions passed or returned as first-class values. https://github.com/rescript-lang/rescript/pull/8321
 - Prevent the developer playground from loading stale compiler and library assets after PR preview updates. https://github.com/rescript-lang/rescript/pull/8556

compiler/ml/ctype.ml

@@ -2740,8 +2740,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
               | Tvar _, _ when may_instantiate inst_nongen t1' ->
                 moregen_occur env t1'.level t2;
                 link_type t1' t2
-              | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _)
-                when Asttypes.same_arg_label arg1.lbl arg2.lbl ->
+              | Tarrow (arg1, ret1, a1), Tarrow (arg2, ret2, a2)
+                when a1 = a2 && Asttypes.same_arg_label arg1.lbl arg2.lbl ->
                 moregen inst_nongen type_pairs env arg1.typ arg2.typ;
                 moregen inst_nongen type_pairs env ret1 ret2
               | Ttuple tl1, Ttuple tl2 ->
@@ -3010,8 +3010,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
                   if List.exists (fun (_, t) -> t == t2') !subst then
                     raise (Unify []);
                   subst := (t1', t2') :: !subst)
-              | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _)
-                when Asttypes.same_arg_label arg1.lbl arg2.lbl ->
+              | Tarrow (arg1, ret1, a1), Tarrow (arg2, ret2, a2)
+                when a1 = a2 && Asttypes.same_arg_label arg1.lbl arg2.lbl ->
                 eqtype rename type_pairs subst env arg1.typ arg2.typ;
                 eqtype rename type_pairs subst env ret1 ret2
               | Ttuple tl1, Ttuple tl2 ->
@@ -3410,8 +3410,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
       Type_pairs.add subtypes (t1, t2) ();
       match (t1.desc, t2.desc) with
       | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs
-      | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _)
-        when Asttypes.same_arg_label arg1.lbl arg2.lbl ->
+      | Tarrow (arg1, ret1, a1), Tarrow (arg2, ret2, a2)
+        when a1 = a2 && Asttypes.same_arg_label arg1.lbl arg2.lbl ->
         let cstrs =
           subtype_rec env
             ((arg2.typ, arg1.typ) :: trace)

compiler/ml/includemod.ml

@@ -493,16 +493,54 @@ let show_locs ppf (loc1, loc2) =
   show_loc "Expected declaration" ppf loc2;
   show_loc "Actual declaration" ppf loc1
 
-let include_err ppf = function
+let find_arity_mismatch env ty1 ty2 =
+  let rec loop seen ty1 ty2 =
+    let ty1 = Btype.repr ty1 in
+    let ty2 = Btype.repr ty2 in
+    if List.exists (fun (t1, t2) -> t1 == ty1 && t2 == ty2) seen then None
+    else
+      let seen = (ty1, ty2) :: seen in
+      let ty1 = Btype.repr (Ctype.expand_head env ty1) in
+      let ty2 = Btype.repr (Ctype.expand_head env ty2) in
+      match (ty1.desc, ty2.desc) with
+      | Tarrow (arg1, ret1, arity1), Tarrow (arg2, ret2, arity2) -> (
+        match (arity1, arity2) with
+        | Some n1, Some n2 when n1 <> n2 -> Some (n1, n2)
+        | _ when arity1 = arity2 && Asttypes.same_arg_label arg1.lbl arg2.lbl
+          -> (
+          match loop seen arg1.typ arg2.typ with
+          | Some _ as mismatch -> mismatch
+          | None -> loop seen ret1 ret2)
+        | _ -> None)
+      | _ -> None
+  in
+  loop [] ty1 ty2
+
+let show_arity_mismatch env ppf (d1 : value_description)
+    (d2 : value_description) =
+  match find_arity_mismatch env d1.val_type d2.val_type with
+  | Some (n1, n2) ->
+    let args n =
+      if n = 1 then "1 argument" else string_of_int n ^ " arguments"
+    in
+    fprintf ppf
+      "@\n\
+       @[The implementation contains a function taking %s where the interface \
+       expects one taking %s.@ A function's arity is part of its type: calls \
+       are compiled to plain JavaScript calls with exactly that many \
+       arguments.@]"
+      (args n1) (args n2)
+  | _ -> ()
+
+let include_symptom env ppf = function
   | Missing_field (id, loc, kind) ->
     fprintf ppf "The %s `%a' is required but not provided" kind ident id;
     show_loc "Expected declaration" ppf loc
   | Value_descriptions (id, d1, d2) ->
-    let curry_kind_1, curry_kind_2 = ("", "") in
     fprintf ppf
-      "@[<hv 2>Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]"
-      (value_description id) d1 curry_kind_1 (value_description id) d2
-      curry_kind_2;
+      "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
+      (value_description id) d1 (value_description id) d2;
+    show_arity_mismatch env ppf d1 d2;
     show_locs ppf (d1.val_loc, d2.val_loc)
   | Type_declarations (id, d1, d2, errs) ->
     fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
@@ -584,7 +622,7 @@ let context ppf cxt =
 
 let include_err ppf (cxt, env, err) =
   Printtyp.wrap_printing_env env (fun () ->
-      fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err)
+      fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) (include_symptom env) err)
 
 let buffer = ref Bytes.empty
 let is_big obj =

tests/ERROR_VARIANTS.md

@@ -208,7 +208,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml).
 | `Undefined_method` | ✓ | `super_errors_multi/Cross_module_alias_dot_access`, `undefined_method` | |
 | `Private_type` | ✓ | `private_type_construction.res` | |
 | `Private_label` | ✓ | `private_label.res` | |
-| `Not_subtype` | ✓ | `subtype_*.res`, `dict_show_no_coercion.res`, etc. | |
+| `Not_subtype` | ✓ | `subtype_*.res`, `coercion_arity_mismatch.res`, `dict_show_no_coercion.res`, etc. | |
 | `Too_many_arguments` | ✓ | `too_many_arguments.res`, `moreArguments*.res` | |
 | `Abstract_wrong_label` | ✓ | `abstract_wrong_label.res` | Multi-arg function literal where an inner argument label doesn't match the expected arrow's label (e.g. `let f: (~a, ~b) => int = (~a, ~c) => …`). |
 | `Scoping_let_module` | ✓ | `scoping_let_module.res` | |
@@ -353,8 +353,8 @@ Wrapper symptoms attached to inclusion failures. Source: [includemod.ml:23](../c
 | Variant | Status | Fixture | Notes |
 |---|---|---|---|
 | `Missing_field` | ✓ | `super_errors_multi/Iface_missing_value` | |
-| `Value_descriptions` | ✓ | `super_errors_multi/Iface_value_descriptions`, `super_errors_multi/Smoke_interface_mismatch` | |
-| `Type_declarations` | ✓ | `super_errors_multi/Iface_type_decl_record`, `super_errors_multi/Iface_type_decl_variant`, `RecordInclusion.res` | |
+| `Value_descriptions` | ✓ | `super_errors_multi/Iface_value_descriptions`, `super_errors_multi/Iface_value_arity_mismatch`, `super_errors_multi/Smoke_interface_mismatch`, `module_sig_value_arity_mismatch*.res` | Arity mismatches print a dedicated hint (implementation vs interface argument counts), including through aliases and nested function types. |
+| `Type_declarations` | ✓ | `super_errors_multi/Iface_type_decl_record`, `super_errors_multi/Iface_type_decl_variant`, `RecordInclusion.res`, `type_decl_function_arity_mismatch.res` | |
 | `Extension_constructors` | ✓ | `super_errors_multi/Iface_extension_constructors` | |
 | `Module_types` | ✓ | `super_errors_multi/Iface_module_types` | |
 | `Modtype_infos` | ✓ | `super_errors_multi/Iface_modtype_infos` | |
@@ -377,7 +377,7 @@ Source: [includecore.ml:159](../compiler/ml/includecore.ml).
 | `Privacy` | ✓ | `super_errors_multi/Iface_privacy_mismatch` | |
 | `Kind` | ✓ | `super_errors_multi/Iface_kind_mismatch` | Record-in-impl vs variant-in-interface. |
 | `Constraint` | ✓ | `super_errors_multi/Iface_constraint_mismatch` | Implementation adds a `constraint 'a = …`; interface has none. |
-| `Manifest` | ✓ | `super_errors_multi/Iface_manifest_mismatch` | Manifest types differ (`int` vs `string`). |
+| `Manifest` | ✓ | `super_errors_multi/Iface_manifest_mismatch`, `type_decl_function_arity_mismatch.res` | Manifest types differ, including function types with different arities. |
 | `Variance` | ✓ | `super_errors_multi/Iface_variance_mismatch` | Interface annotates `+'a`; implementation's inferred variance differs. |
 | `Field_type` | ✓ | `super_errors_multi/Iface_type_decl_record` | |
 | `Field_mutable` | ✓ | `super_errors_multi/Iface_field_mutable_mismatch` | |

tests/build_tests/super_errors/expected/coercion_arity_mismatch.res.expected

@@ -0,0 +1,9 @@
+
+  We've found a bug for you!
+  /.../fixtures/coercion_arity_mismatch.res:2:10-31
+
+  1 │ let f = (x: int) => (y: int) => x + y
+  2 │ let g = (f :> (int, int) => int)
+  3 │ 
+
+  Type int => int => int is not a subtype of (int, int) => int

tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch.res.expected

@@ -0,0 +1,30 @@
+
+  We've found a bug for you!
+  /.../fixtures/module_sig_value_arity_mismatch.res:3:5-5:1
+
+  1 │ module M: {
+  2 │   let f: (int, int) => int
+  3 │ } = {
+  4 │   let f = (x: int) => (y: int) => x + y
+  5 │ }
+  6 │ 
+
+  Signature mismatch:
+  Modules do not match:
+    {
+  let f: int => int => int
+}
+  is not included in
+    {
+  let f: (int, int) => int
+}
+  Values do not match:
+    let f: int => int => int
+  is not included in
+    let f: (int, int) => int
+  The implementation contains a function taking 1 argument where the interface expects one taking 2 arguments.
+  A function's arity is part of its type: calls are compiled to plain JavaScript calls with exactly that many arguments.
+  /.../fixtures/module_sig_value_arity_mismatch.res:2:3-26:
+    Expected declaration
+  /.../fixtures/module_sig_value_arity_mismatch.res:4:7:
+    Actual declaration

tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch_alias.res.expected

@@ -0,0 +1,30 @@
+
+  We've found a bug for you!
+  /.../fixtures/module_sig_value_arity_mismatch_alias.res:5:5-7:1
+
+  3 │ module M: {
+  4 │   let f: (int, int) => int
+  5 │ } = {
+  6 │   let f: curried = (x: int) => (_y: int) => x
+  7 │ }
+  8 │ 
+
+  Signature mismatch:
+  Modules do not match:
+    {
+  let f: curried
+}
+  is not included in
+    {
+  let f: (int, int) => int
+}
+  Values do not match:
+    let f: curried
+  is not included in
+    let f: (int, int) => int
+  The implementation contains a function taking 1 argument where the interface expects one taking 2 arguments.
+  A function's arity is part of its type: calls are compiled to plain JavaScript calls with exactly that many arguments.
+  /.../fixtures/module_sig_value_arity_mismatch_alias.res:4:3-26:
+    Expected declaration
+  /.../fixtures/module_sig_value_arity_mismatch_alias.res:6:7:
+    Actual declaration

tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch_nested.res.expected

@@ -0,0 +1,30 @@
+
+  We've found a bug for you!
+  /.../fixtures/module_sig_value_arity_mismatch_nested.res:3:5-5:1
+
+  1 │ module M: {
+  2 │   let f: int => (int, int) => int
+  3 │ } = {
+  4 │   let f = (_x: int) => (y: int) => (_z: int) => y
+  5 │ }
+  6 │ 
+
+  Signature mismatch:
+  Modules do not match:
+    {
+  let f: int => int => int => int
+}
+  is not included in
+    {
+  let f: int => (int, int) => int
+}
+  Values do not match:
+    let f: int => int => int => int
+  is not included in
+    let f: int => (int, int) => int
+  The implementation contains a function taking 1 argument where the interface expects one taking 2 arguments.
+  A function's arity is part of its type: calls are compiled to plain JavaScript calls with exactly that many arguments.
+  /.../fixtures/module_sig_value_arity_mismatch_nested.res:2:3-33:
+    Expected declaration
+  /.../fixtures/module_sig_value_arity_mismatch_nested.res:4:7:
+    Actual declaration

tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch_reverse.res.expected

@@ -0,0 +1,30 @@
+
+  We've found a bug for you!
+  /.../fixtures/module_sig_value_arity_mismatch_reverse.res:3:5-5:1
+
+  1 │ module M: {
+  2 │   let f: int => int => int
+  3 │ } = {
+  4 │   let f = (x: int, _y: int) => x
+  5 │ }
+  6 │ 
+
+  Signature mismatch:
+  Modules do not match:
+    {
+  let f: (int, int) => int
+}
+  is not included in
+    {
+  let f: int => int => int
+}
+  Values do not match:
+    let f: (int, int) => int
+  is not included in
+    let f: int => int => int
+  The implementation contains a function taking 2 arguments where the interface expects one taking 1 argument.
+  A function's arity is part of its type: calls are compiled to plain JavaScript calls with exactly that many arguments.
+  /.../fixtures/module_sig_value_arity_mismatch_reverse.res:2:3-26:
+    Expected declaration
+  /.../fixtures/module_sig_value_arity_mismatch_reverse.res:4:7:
+    Actual declaration

tests/build_tests/super_errors/expected/type_decl_function_arity_mismatch.res.expected

@@ -0,0 +1,28 @@
+
+  We've found a bug for you!
+  /.../fixtures/type_decl_function_arity_mismatch.res:3:5-5:1
+
+  1 │ module M: {
+  2 │   type t = (int, int) => int
+  3 │ } = {
+  4 │   type t = int => int => int
+  5 │ }
+  6 │ 
+
+  Signature mismatch:
+  Modules do not match:
+    {
+  type t = int => int => int
+}
+  is not included in
+    {
+  type t = (int, int) => int
+}
+  Type declarations do not match:
+    type t = int => int => int
+  is not included in
+    type t = (int, int) => int
+  /.../fixtures/type_decl_function_arity_mismatch.res:2:3-28:
+    Expected declaration
+  /.../fixtures/type_decl_function_arity_mismatch.res:4:3-28:
+    Actual declaration

tests/build_tests/super_errors/fixtures/coercion_arity_mismatch.res

@@ -0,0 +1,2 @@
+let f = (x: int) => (y: int) => x + y
+let g = (f :> (int, int) => int)

tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch.res

@@ -0,0 +1,5 @@
+module M: {
+  let f: (int, int) => int
+} = {
+  let f = (x: int) => (y: int) => x + y
+}

tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch_alias.res

@@ -0,0 +1,7 @@
+type curried = int => int => int
+
+module M: {
+  let f: (int, int) => int
+} = {
+  let f: curried = (x: int) => (_y: int) => x
+}

tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch_nested.res

@@ -0,0 +1,5 @@
+module M: {
+  let f: int => (int, int) => int
+} = {
+  let f = (_x: int) => (y: int) => (_z: int) => y
+}

tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch_reverse.res

@@ -0,0 +1,5 @@
+module M: {
+  let f: int => int => int
+} = {
+  let f = (x: int, _y: int) => x
+}

tests/build_tests/super_errors/fixtures/type_decl_function_arity_mismatch.res

@@ -0,0 +1,5 @@
+module M: {
+  type t = (int, int) => int
+} = {
+  type t = int => int => int
+}

tests/build_tests/super_errors_multi/expected/Iface_value_arity_mismatch.expected

@@ -0,0 +1,20 @@
+===== Foo.res =====
+
+  We've found a bug for you!
+  /.../fixtures/Iface_value_arity_mismatch/Foo.res:1:5
+
+  1 │ let f = (x: int) => (y: int) => x + y
+  2 │ 
+
+  The implementation /.../fixtures/Iface_value_arity_mismatch/Foo.res
+  does not match the interface /.../fixtures/Iface_value_arity_mismatch/foo.cmi:
+  Values do not match:
+    let f: int => int => int
+  is not included in
+    let f: (int, int) => int
+  The implementation contains a function taking 1 argument where the interface expects one taking 2 arguments.
+  A function's arity is part of its type: calls are compiled to plain JavaScript calls with exactly that many arguments.
+  /.../fixtures/Iface_value_arity_mismatch/Foo.resi:1:1-24:
+    Expected declaration
+  /.../fixtures/Iface_value_arity_mismatch/Foo.res:1:5:
+    Actual declaration

tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.res

@@ -0,0 +1 @@
+let f = (x: int) => (y: int) => x + y

tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.resi

@@ -0,0 +1 @@
+let f: (int, int) => int