Fix partial application for uncurried functions with labeled args (#6198)

Partial application for uncurried functions used normal application.
There's an issue with the code generated in the presence of labeled arguments, ad the function generated is curried.

This PR changes the translation from typed ast to lambda for the uncurried partial application case, by writing a single function with all the leftover arguments. So it correctly represents an uncurried function.

Fixex #6164

Author: cristianoc

CHANGELOG.md

@@ -27,6 +27,7 @@
 #### :bug: Bug Fix
 
 - Make "rescript format" work with node 10 again and set minimum required node version to 10 in package.json. https://github.com/rescript-lang/rescript-compiler/pull/6186
+- Fix partial application for uncurried functions with labeled args https://github.com/rescript-lang/rescript-compiler/pull/6198
 
 # 11.0.0-alpha.4
 

jscomp/ml/ast_uncurried.ml

@@ -106,3 +106,9 @@ let uncurried_type_get_arity ~env typ =
   | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) ->
       type_to_arity tArity
   | _ -> assert false
+
+let uncurried_type_get_arity_opt ~env typ =
+  match (Ctype.expand_head env typ).desc with
+  | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) ->
+      Some (type_to_arity tArity)
+  | _ -> None

jscomp/ml/translcore.ml

@@ -762,7 +762,14 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
       let inlined, funct =
         Translattribute.get_and_remove_inlined_attribute funct
       in
-      transl_apply ~inlined (transl_exp funct) oargs e.exp_loc
+      let uncurried_partial_application =
+        let uncurried_partial_app = Ext_list.exists e.exp_attributes (fun ({txt },_) -> txt = "res.partial") in
+        if uncurried_partial_app then
+          let arity_opt = Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env funct.exp_type in   
+          arity_opt
+        else
+          None in
+      transl_apply ~inlined ~uncurried_partial_application (transl_exp funct) oargs e.exp_loc
   | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) ->
       transl_match e arg pat_expr_list exn_pat_expr_list partial
   | Texp_try (body, pat_expr_list) ->
@@ -978,7 +985,7 @@ and transl_cases_try cases =
   in
   List.map transl_case_try cases
 
-and transl_apply ?(inlined = Default_inline) lam sargs loc =
+and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application=None) lam sargs loc =
   let lapply funct args =
     match funct with
     (* Attention: This may not be what we need to change the application arity*)
@@ -1028,11 +1035,36 @@ and transl_apply ?(inlined = Default_inline) lam sargs loc =
     | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l
     | [] -> lapply lam (List.rev_map fst args)
   in
-  (build_apply lam []
-     (List.map
-        (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l))
-        sargs)
-    : Lambda.lambda)
+  match uncurried_partial_application with
+    | Some arity when arity > List.length sargs ->
+    let extra_arity = arity - List.length sargs in
+    let none_ids = ref [] in
+    let args = Ext_list.filter_map sargs (function
+     | _, Some e ->
+        Some (transl_exp e)
+     | _, None ->
+        let id_arg = Ident.create "none" in
+        none_ids := id_arg :: !none_ids;
+        Some (Lvar id_arg)) in
+    let extra_ids = ref [] in
+    extra_ids := Ident.create "extra" :: !extra_ids;
+    let extra_ids = Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list in
+    let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in
+    let ap_args = args @ extra_args in
+    let l0 = Lapply { ap_func = lam; ap_args; ap_inlined = inlined; ap_loc = loc } in
+    Lfunction
+      {
+        params = List.rev_append !none_ids extra_ids ;
+        body = l0;
+        attr = default_function_attribute;
+        loc;
+      }
+  | _ ->
+    (build_apply lam []
+      (List.map
+          (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l))
+          sargs)
+      : Lambda.lambda)
 
 and transl_function loc partial param cases =
   match cases with

jscomp/ml/typecore.ml

@@ -3035,7 +3035,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
       (fully_applied, newT)
     | _ -> (false, newT)
   in
-  let rec type_unknown_args max_arity (args : lazy_args) omitted ty_fun (syntax_args : sargs)
+  let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun (syntax_args : sargs)
      : targs * _ = 
     match syntax_args with
     | [] ->
@@ -3050,14 +3050,14 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
           | Tarrow (Optional l,t1,t2,_) ->
             ignored := (Optional l,t1,ty_fun.level) :: !ignored;
             let arg = Optional l, Some (fun () -> option_none (instance env t1) Location.none) in
-            type_unknown_args max_arity (arg::args) omitted t2 []
+            type_unknown_args max_arity ~args:(arg::args) omitted t2 []
           | _ -> collect_args ())
         else
           collect_args ()
     | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})]
       when uncurried && omitted = [] && args <> [] && List.length args = List.length !ignored ->
       (* foo(. ) treated as empty application if all args are optional (hence ignored) *)
-        type_unknown_args max_arity args omitted ty_fun []
+        type_unknown_args max_arity ~args omitted ty_fun []
     | (l1, sarg1) :: sargl ->
         let (ty1, ty2) =
           let ty_fun = expand_head env ty_fun in
@@ -3097,7 +3097,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
             unify_exp env arg1 (type_option(newvar()));
           arg1
         in
-        type_unknown_args max_arity ((l1, Some arg1) :: args) omitted ty2 sargl
+        type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 sargl
   in
   let rec type_args max_arity args omitted ~ty_fun ty_fun0  ~(sargs : sargs)  =
     match expand_head env ty_fun, expand_head env ty_fun0 with
@@ -3130,7 +3130,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex
         in
         type_args max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs 
     | _ ->
-        type_unknown_args max_arity args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
+        type_unknown_args max_arity ~args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*)
   in
   let () =  
     let ls, tvar = list_labels env funct.exp_type in

jscomp/test/UncurriedAlways.js

@@ -32,3 +32,36 @@ let inl = () => ()
 
 @inline
 let inl2 = (x,y) => x+y
+
+module AllLabels = {
+  let foo = (~x, ~y, ~z) => (x, y, z)
+
+  let ptl = foo(~y="y", ...)
+
+  let a1 = ptl(~x="x", ~z="z")
+  Js.log2("a1:", a1)
+}
+
+module OptAtEnd = {
+  let foo = (~x, ~y, ~z, ~d="d=0") => (x, y, z, d)
+
+  let ptl = foo(~y="y", ...)
+
+  let b1 = ptl(~x="x", ~z="z")
+  Js.log2("b1:", b1)
+  let b2 = ptl(~x="x", ~z="z", ~d="d<-100")
+  Js.log2("b2:", b2)
+}
+
+module OptMixed = {
+  let foo = (~d1="d1=0", ~x, ~d2="d2=0",  ~y, ~d3="d3=0", ~z, ~d4="d4=0", ~w, ~d5="d5=0") => (d1, x, d2, y, d3, z, d4, w, d5)
+
+  let ptl = foo(~y="y", ~w="w", ...)
+
+  let c1 = ptl(~x="x", ~z="z")
+  Js.log2("c1:", c1)
+  let c2 = ptl(~x="x", ~z="z", ~d1="d1<-100")
+  Js.log2("c2:", c2)
+  let c3 = ptl(~x="x", ~z="z", ~d2="d2<-200", ~d4="d4<-400")
+  Js.log2("c3:", c3)
+}