Partial application of an uncurried type returns an uncurried type.

Author: cristianoc

CHANGELOG.md

@@ -17,6 +17,8 @@
 - Introduce experimental uncurried by default mode. Can be turned on mid-file by adding standalone annotation `@@uncurried`. For experimentation only. https://github.com/rescript-lang/rescript-compiler/pull/5796
 - Adding `@@toUncurried` to the file and reformat will convert to uncurried syntax https://github.com/rescript-lang/rescript-compiler/pull/5800
 - Add support for unary uncurried pipe in uncurried mode https://github.com/rescript-lang/rescript-compiler/pull/5804
+- Add support for partial application of uncurried functions: with uncurried application one can provide a
+subset of the arguments, and return a curried type with the remaining ones https://github.com/rescript-lang/rescript-compiler/pull/5805
 
 #### :boom: Breaking Change
 

jscomp/ml/typecore.ml

@@ -2949,6 +2949,26 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
     tvar || List.mem l ls
   in
   let ignored = ref [] in
+  let extract_uncurried t =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[t],_) -> t
+    | _ -> t in
+  let lower_uncurried_arity ~nargs t newT =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),[_],_) ->
+      let arity =
+        if String.sub a 0 5 = "arity"
+        then int_of_string (String.sub a 5 (String.length a - 5))
+        else 0 in
+      let newarity = arity - nargs in
+      if newarity > 0 then
+        let a = "arity" ^ string_of_int newarity in
+        let lid:Longident.t = Ldot (Ldot (Lident "Js", "Fn"), a) in
+        let path = Env.lookup_type lid env in
+        newconstr path [newT]
+      else newT
+    | _ -> newT
+  in
   let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
      : targs * _ = 
     match syntax_args with 
@@ -2968,7 +2988,6 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
                 Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
               unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
               (t1, t2)
-          | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[{desc=Tarrow (l,t1,t2,_)}],_)
           | Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1
             ->
               (t1, t2)
@@ -3059,8 +3078,10 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
       end;
       ([Nolabel, Some exp], ty_res)
   | _ ->
-      let ty = funct.exp_type in
-      type_args [] [] ~ty_fun:ty (instance env ty) ~sargs
+      let ty_ = funct.exp_type in
+      let ty = extract_uncurried ty_ in
+      let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
+      targs, lower_uncurried_arity ty_ ~nargs:(List.length !ignored + List.length sargs) ret_t
 
 and type_construct env loc lid sarg ty_expected attrs =
   let opath =

jscomp/test/uncurried_cast.js

@@ -54,11 +54,26 @@ var ll = Curry._1(partial, (function (x) {
         return x + 1 | 0;
       }));
 
+function withOpts(xOpt, y, zOpt, w) {
+  var x = xOpt !== undefined ? xOpt : 3;
+  var z = zOpt !== undefined ? zOpt : 4;
+  return ((x + y | 0) + z | 0) + w | 0;
+}
+
+function still2Args(param, param$1) {
+  return withOpts(undefined, 4, param, param$1);
+}
+
+var anInt = still2Args(3, 5);
+
 var StandardNotation = {
   testRaise: testRaise,
   l: l,
   partial: partial,
-  ll: ll
+  ll: ll,
+  withOpts: withOpts,
+  still2Args: still2Args,
+  anInt: anInt
 };
 
 function testRaise$1() {
@@ -93,11 +108,26 @@ var ll$1 = partial$1(function (x) {
       return x + 1 | 0;
     });
 
+function withOpts$1(xOpt, y, zOpt, w) {
+  var x = xOpt !== undefined ? xOpt : 3;
+  var z = zOpt !== undefined ? zOpt : 4;
+  return ((x + y | 0) + z | 0) + w | 0;
+}
+
+function still2Args$1(param, param$1) {
+  return withOpts$1(undefined, 4, param, param$1);
+}
+
+var anInt$1 = still2Args$1(3, 5);
+
 exports.Uncurried = Uncurried;
 exports.E = E;
 exports.StandardNotation = StandardNotation;
 exports.testRaise = testRaise$1;
 exports.l = l$1;
 exports.partial = partial$1;
 exports.ll = ll$1;
+exports.withOpts = withOpts$1;
+exports.still2Args = still2Args$1;
+exports.anInt = anInt$1;
 /* l Not a pure module */

jscomp/test/uncurried_cast.res

@@ -14,10 +14,12 @@ module StandardNotation = {
   let testRaise = () => raise(E)
 
   let l = List.map(.list{1, 2}, (. x) => x + 1)
-
   let partial = List.map(list{1, 2})
-
   let ll = partial((. x) => x + 1)
+
+  let withOpts = (. ~x=3, y, ~z=4, w) => x + y + z + w
+  let still2Args : (. ~z: int=?, int) => int = withOpts(4)
+  let anInt = still2Args(. ~z=3, 5)
 }
 
 @@uncurried
@@ -27,7 +29,9 @@ open Uncurried
 let testRaise = () => raise(E)
 
 let l = List.map(list{1, 2}, x => x + 1)
-
 let partial = List.map(. list{1, 2})
-
 let ll = partial(.x => x + 1)
+
+let withOpts = (~x=3, y, ~z=4, w) => x + y + z + w
+let still2Args : (~z: int=?, int) => int = withOpts(. 4)
+let anInt = still2Args(~z=3, 5)

lib/4.06.1/unstable/js_compiler.ml

@@ -43647,6 +43647,26 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
     tvar || List.mem l ls
   in
   let ignored = ref [] in
+  let extract_uncurried t =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[t],_) -> t
+    | _ -> t in
+  let lower_uncurried_arity ~nargs t newT =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),[_],_) ->
+      let arity =
+        if String.sub a 0 5 = "arity"
+        then int_of_string (String.sub a 5 (String.length a - 5))
+        else 0 in
+      let newarity = arity - nargs in
+      if newarity > 0 then
+        let a = "arity" ^ string_of_int newarity in
+        let lid:Longident.t = Ldot (Ldot (Lident "Js", "Fn"), a) in
+        let path = Env.lookup_type lid env in
+        newconstr path [newT]
+      else newT
+    | _ -> newT
+  in
   let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
      : targs * _ = 
     match syntax_args with 
@@ -43666,7 +43686,6 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
                 Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
               unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
               (t1, t2)
-          | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[{desc=Tarrow (l,t1,t2,_)}],_)
           | Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1
             ->
               (t1, t2)
@@ -43757,8 +43776,10 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
       end;
       ([Nolabel, Some exp], ty_res)
   | _ ->
-      let ty = funct.exp_type in
-      type_args [] [] ~ty_fun:ty (instance env ty) ~sargs
+      let ty_ = funct.exp_type in
+      let ty = extract_uncurried ty_ in
+      let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
+      targs, lower_uncurried_arity ty_ ~nargs:(List.length !ignored + List.length sargs) ret_t
 
 and type_construct env loc lid sarg ty_expected attrs =
   let opath =

lib/4.06.1/unstable/js_playground_compiler.ml

@@ -43647,6 +43647,26 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
     tvar || List.mem l ls
   in
   let ignored = ref [] in
+  let extract_uncurried t =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[t],_) -> t
+    | _ -> t in
+  let lower_uncurried_arity ~nargs t newT =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),[_],_) ->
+      let arity =
+        if String.sub a 0 5 = "arity"
+        then int_of_string (String.sub a 5 (String.length a - 5))
+        else 0 in
+      let newarity = arity - nargs in
+      if newarity > 0 then
+        let a = "arity" ^ string_of_int newarity in
+        let lid:Longident.t = Ldot (Ldot (Lident "Js", "Fn"), a) in
+        let path = Env.lookup_type lid env in
+        newconstr path [newT]
+      else newT
+    | _ -> newT
+  in
   let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
      : targs * _ = 
     match syntax_args with 
@@ -43666,7 +43686,6 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
                 Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
               unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
               (t1, t2)
-          | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[{desc=Tarrow (l,t1,t2,_)}],_)
           | Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1
             ->
               (t1, t2)
@@ -43757,8 +43776,10 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
       end;
       ([Nolabel, Some exp], ty_res)
   | _ ->
-      let ty = funct.exp_type in
-      type_args [] [] ~ty_fun:ty (instance env ty) ~sargs
+      let ty_ = funct.exp_type in
+      let ty = extract_uncurried ty_ in
+      let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
+      targs, lower_uncurried_arity ty_ ~nargs:(List.length !ignored + List.length sargs) ret_t
 
 and type_construct env loc lid sarg ty_expected attrs =
   let opath =

lib/4.06.1/whole_compiler.ml

@@ -98642,6 +98642,26 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
     tvar || List.mem l ls
   in
   let ignored = ref [] in
+  let extract_uncurried t =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[t],_) -> t
+    | _ -> t in
+  let lower_uncurried_arity ~nargs t newT =
+    match t.desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),[_],_) ->
+      let arity =
+        if String.sub a 0 5 = "arity"
+        then int_of_string (String.sub a 5 (String.length a - 5))
+        else 0 in
+      let newarity = arity - nargs in
+      if newarity > 0 then
+        let a = "arity" ^ string_of_int newarity in
+        let lid:Longident.t = Ldot (Ldot (Lident "Js", "Fn"), a) in
+        let path = Env.lookup_type lid env in
+        newconstr path [newT]
+      else newT
+    | _ -> newT
+  in
   let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
      : targs * _ = 
     match syntax_args with 
@@ -98661,7 +98681,6 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
                 Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
               unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
               (t1, t2)
-          | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[{desc=Tarrow (l,t1,t2,_)}],_)
           | Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1
             ->
               (t1, t2)
@@ -98752,8 +98771,10 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
       end;
       ([Nolabel, Some exp], ty_res)
   | _ ->
-      let ty = funct.exp_type in
-      type_args [] [] ~ty_fun:ty (instance env ty) ~sargs
+      let ty_ = funct.exp_type in
+      let ty = extract_uncurried ty_ in
+      let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
+      targs, lower_uncurried_arity ty_ ~nargs:(List.length !ignored + List.length sargs) ret_t
 
 and type_construct env loc lid sarg ty_expected attrs =
   let opath =