Add support for partial application of uncurried functions

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_type t =
+    match (expand_head env t).desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[t],_) -> t
+    | _ -> t in
+  let lower_uncurried_arity ~nargs t newT =
+    match (expand_head env 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 
@@ -3058,8 +3078,12 @@ 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 = extract_uncurried_type funct.exp_type in
+      let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
+      let ret_t =
+        if funct.exp_type == ty then ret_t
+        else lower_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in
+      targs, ret_t
 
 and type_construct env loc lid sarg ty_expected attrs =
   let opath =

jscomp/test/uncurried_cast.js

@@ -0,0 +1,137 @@
+'use strict';
+
+var Curry = require("../../lib/js/curry.js");
+var Belt_List = require("../../lib/js/belt_List.js");
+var Caml_exceptions = require("../../lib/js/caml_exceptions.js");
+
+function raise(e) {
+  throw e;
+}
+
+var map = Belt_List.mapU;
+
+var List = {
+  map: map
+};
+
+var Uncurried = {
+  raise: raise,
+  List: List
+};
+
+var E = /* @__PURE__ */Caml_exceptions.create("Uncurried_cast.E");
+
+function testRaise(param) {
+  throw {
+        RE_EXN_ID: E,
+        Error: new Error()
+      };
+}
+
+var l = map({
+      hd: 1,
+      tl: {
+        hd: 2,
+        tl: /* [] */0
+      }
+    }, (function (x) {
+        return x + 1 | 0;
+      }));
+
+var partial_arg = {
+  hd: 1,
+  tl: {
+    hd: 2,
+    tl: /* [] */0
+  }
+};
+
+function partial(param) {
+  return map(partial_arg, param);
+}
+
+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 = Curry._1(still2Args, 3)(5);
+
+var StandardNotation = {
+  testRaise: testRaise,
+  l: l,
+  partial: partial,
+  ll: ll,
+  withOpts: withOpts,
+  still2Args: still2Args,
+  anInt: anInt
+};
+
+function testRaise$1() {
+  return raise({
+              RE_EXN_ID: E
+            });
+}
+
+var l$1 = map({
+      hd: 1,
+      tl: {
+        hd: 2,
+        tl: /* [] */0
+      }
+    }, (function (x) {
+        return x + 1 | 0;
+      }));
+
+var partial_arg$1 = {
+  hd: 1,
+  tl: {
+    hd: 2,
+    tl: /* [] */0
+  }
+};
+
+function partial$1(param) {
+  return map(partial_arg$1, param);
+}
+
+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 partial_arg$2 = 3;
+
+var anInt$1 = (function (param) {
+      return still2Args$1(partial_arg$2, param);
+    })(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

@@ -0,0 +1,39 @@
+module Uncurried = {
+  let raise = (. e) => raise(e)
+
+  module List = {
+    let map = (. l, f) => Belt.List.mapU(l, f)
+  }
+}
+
+exception E
+
+module StandardNotation = {
+  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
+  type unc2 = (. ~z: int=?, int) => int
+  let still2Args : unc2 = withOpts(4)
+  let anInt = still2Args(~z=3)(. 5)
+}
+
+@@uncurried
+
+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
+type unc2 = (~z: int=?, int) => int
+let still2Args : unc2 = 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_type t =
+    match (expand_head env t).desc with
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[t],_) -> t
+    | _ -> t in
+  let lower_uncurried_arity ~nargs t newT =
+    match (expand_head env 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 
@@ -43756,8 +43776,12 @@ 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 = extract_uncurried_type funct.exp_type in
+      let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
+      let ret_t =
+        if funct.exp_type == ty then ret_t
+        else lower_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in
+      targs, ret_t
 
 and type_construct env loc lid sarg ty_expected attrs =
   let opath =
@@ -154453,6 +154477,11 @@ let transformStructureItem ~config mapper item =
         config.hasReactComponent <- true;
         check_string_int_attribute_iter.structure_item
           check_string_int_attribute_iter item;
+        let pval_type =
+          match pval_type.ptyp_desc with
+          | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, [t]) -> t
+          | _ -> pval_type
+        in
         let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in
         let typVarsOfCoreType =
           coreTypeOfAttr
@@ -154519,12 +154548,21 @@ let transformStructureItem ~config mapper item =
           React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc
         else (
           config.hasReactComponent <- true;
-          let binding =
-            match binding.pvb_expr.pexp_desc with
+          let rec removeArityRecord expr =
+            match expr.pexp_desc with
             | Pexp_record
                 ([({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, e)], None) ->
-              {binding with pvb_expr = e}
-            | _ -> binding
+              e
+            | Pexp_apply (forwardRef, [(label, e)]) ->
+              {
+                expr with
+                pexp_desc =
+                  Pexp_apply (forwardRef, [(label, removeArityRecord e)]);
+              }
+            | _ -> expr
+          in
+          let binding =
+            {binding with pvb_expr = removeArityRecord binding.pvb_expr}
           in
           let coreTypeOfAttr =
             React_jsx_common.coreTypeOfAttrs binding.pvb_attributes