Cleanup and type errot tests.

Author: cristianoc

CHANGELOG.md

@@ -38,6 +38,7 @@
 #### :bug: Bug fix
 
 - Fix recursive untagged variant type checking by delaying well-formedness checks until environment construction completes. [#7320](https://github.com/rescript-lang/rescript/pull/7320)
+- Fix incorrect expansion of polymorphic return types in uncurried function applications. https://github.com/rescript-lang/rescript/pull/7338
 
 # 12.0.0-alpha.9
 

compiler/ml/typecore.ml

@@ -3449,7 +3449,6 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression)
 
 and type_application ?type_clash_context total_app env funct (sargs : sargs) :
     targs * Types.type_expr * bool =
-  (* Printf.eprintf "type_application: #args:%d\n" (List.length sargs); *)
   let result_type omitted ty_fun =
     List.fold_left
       (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok, None)))
@@ -3466,7 +3465,6 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
     | Tvar _ when total_app -> true
     | _ -> false
   in
-  (* Printf.eprintf "force_tvar:%b\n" force_tvar; *)
   let has_arity funct =
     let t = funct.exp_type in
     if force_tvar then Some (List.length sargs)
@@ -3552,13 +3550,11 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
       type_unknown_args max_arity ~args ~top_arity:None omitted ty_fun []
     | (l1, sarg1) :: sargl ->
       let l1 = to_noloc l1 in
-      (* let lbl_name = label_name l1 in
-      Printf.eprintf "  type_unknown_args: lbl_name:%s\n" lbl_name; *)
       let ty1, ty2 =
         let ty_fun = expand_head env ty_fun in
         let arity_ok = List.length args < max_arity in
         match ty_fun.desc with
-        | Tvar _ when (* l1 = Nolabel || *) force_tvar ->
+        | Tvar _ when force_tvar ->
           (* This is a total application when the toplevel type is a polymorphic variable,
           so the function type including arity can be inferred. *)
           let t1 = newvar () and t2 = newvar () in
@@ -3611,11 +3607,9 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
       when sargs <> [] && commu_repr com = Cok && List.length args < max_arity
       ->
       let name = label_name l and optional = is_optional l in
-      (* Printf.eprintf "  type_args: name:%s, optional:%b\n" name optional; *)
       let sargs, omitted, arg =
         match extract_label name sargs with
         | None ->
-          (* Printf.eprintf "  extract_label: None\n"; *)
           if optional && (total_app || label_assoc Nolabel sargs) then (
             ignored := (l, ty, lv) :: !ignored;
             ( sargs,
@@ -3648,14 +3642,8 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
         sargs (* This is the hot path for non-labeled function*)
   in
   if total_app then force_uncurried_type funct;
-  (* Printf.eprintf "total_app:%b\n" total_app; *)
   let max_arity = get_max_arity funct in
-  (* Printf.eprintf "max_arity:%d\n" max_arity; *)
   let top_arity = if total_app then Some max_arity else None in
-  (* Printf.eprintf "top_arity:%s\n"
-    (match top_arity with
-    | Some _ -> "Some"
-    | None -> "None"); *)
   match sargs with
   (* Special case for ignore: avoid discarding warning *)
   | [(Nolabel, sarg)] when is_ignore ~env ~arity:top_arity funct ->

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

@@ -0,0 +1,23 @@
+
+  Warning number 20
+  /.../fixtures/fun_return_poly1.res:3:15
+
+  1 │ let f = (_, ~def=3) => assert(false)
+  2 │ 
+  3 │ let ok = f(1)(2)
+  4 │ let err = f(1, 2)
+  5 │ 
+
+  this argument will not be used by the function.
+
+
+  We've found a bug for you!
+  /.../fixtures/fun_return_poly1.res:4:16
+
+  2 │ 
+  3 │ let ok = f(1)(2)
+  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

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

@@ -0,0 +1,24 @@
+
+  Warning number 20
+  /.../fixtures/fun_return_poly2.res:6:30
+
+  4 │ }
+  5 │ 
+  6 │ let ok = r("")(~initialValue=2)
+  7 │ let err = r("", ~initialValue=2)
+  8 │ 
+
+  this argument will not be used by the function.
+
+
+  We've found a bug for you!
+  /.../fixtures/fun_return_poly2.res:7:31
+
+  5 │ 
+  6 │ let ok = r("")(~initialValue=2)
+  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

tests/build_tests/super_errors/fixtures/fun_return_poly1.res

@@ -0,0 +1,4 @@
+let f = (_, ~def=3) => assert(false)
+
+let ok = f(1)(2)
+let err = f(1, 2)

tests/build_tests/super_errors/fixtures/fun_return_poly2.res

@@ -0,0 +1,7 @@
+let r: (string, ~wrongLabelName: int=?) => 'a = (_s, ~wrongLabelName=3) => {
+  let _ = wrongLabelName
+  assert(false)
+}
+
+let ok = r("")(~initialValue=2)
+let err = r("", ~initialValue=2)