Fix partial application for uncurried functions with labeled args

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.res

@@ -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)
+}