Uncurried support for externals part 2 (#5819)

* Uncurried support for externals part 2

Preserve arity during type checking, and reconstruct it during external attributes processing in the front-end.

* Update CHANGELOG.md

Author: cristianoc

CHANGELOG.md

@@ -19,7 +19,7 @@
 - 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
-- Add support for uncurried externals https://github.com/rescript-lang/rescript-compiler/pull/5815
+- Add support for uncurried externals https://github.com/rescript-lang/rescript-compiler/pull/5815 https://github.com/rescript-lang/rescript-compiler/pull/5819
 
 #### :boom: Breaking Change
 

jscomp/frontend/ast_core_type.ml

@@ -130,7 +130,11 @@ let get_uncurry_arity (ty : t) =
   | Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1)
   | _ -> None
 
-let get_curry_arity ty = get_uncurry_arity_aux ty 0
+let get_curry_arity (ty : t) =
+  match ty.ptyp_desc with
+  | Ptyp_constr ({ txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, [ t ]) ->
+      get_uncurry_arity_aux t 0
+  | _ -> get_uncurry_arity_aux ty 0
 
 (* add hoc for bs.send.pipe *)
 let rec get_curry_labels (ty : t) acc =
@@ -139,7 +143,6 @@ let rec get_curry_labels (ty : t) acc =
   | _ -> acc
 
 let get_curry_labels ty = List.rev (get_curry_labels ty [])
-
 let is_arity_one ty = get_curry_arity ty = 1
 
 type param_type = {

jscomp/frontend/ast_external_process.ml

@@ -868,6 +868,15 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     Location.raise_errorf ~loc
       "%@uncurry can not be applied to the whole definition";
   let prim_name_with_source = { name = prim_name; source = External } in
+  let type_annotation, build_uncurried_type = match type_annotation.ptyp_desc with
+    | Ptyp_constr ({txt = Ldot(Ldot(Lident "Js", "Fn"), arity_);_} as lid, [t]) ->
+      t, fun ~arity x ->
+          let arity = match arity with
+            | Some arity -> "arity" ^ string_of_int arity
+            | None -> arity_ in
+          let lid = {lid with txt = Longident.Ldot(Ldot(Lident "Js", "Fn"), arity)} in
+          {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x])}
+    | _ -> type_annotation, fun ~arity:_ x -> x in
   let result_type, arg_types_ty =
     (* Note this assumes external type is syntatic (no abstraction)*)
     Ast_core_type.list_of_arrow type_annotation
@@ -885,7 +894,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     let new_type, spec =
       process_obj loc external_desc prim_name arg_types_ty result_type
     in
-    (new_type, spec, unused_attrs, false)
+    (build_uncurried_type ~arity:None new_type, spec, unused_attrs, false)
   else
     let splice = external_desc.splice in
     let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
@@ -956,7 +965,8 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     let return_wrapper =
       check_return_wrapper loc external_desc.return_wrapper result_type
     in
-    ( Ast_core_type.mk_fn_type new_arg_types_ty result_type,
+    let fn_type = Ast_core_type.mk_fn_type new_arg_types_ty result_type in
+    ( build_uncurried_type ~arity:(Some (List.length new_arg_types_ty)) fn_type,
       External_ffi_types.ffi_bs arg_type_specs return_wrapper ffi,
       unused_attrs,
       relative )

jscomp/ml/typedecl.ml

@@ -1576,19 +1576,13 @@ let rec parse_native_repr_attributes env core_type ty =
   | _ -> ([], Same_as_ocaml_repr)
 
 
-let parse_native_repr_attributes valdecl env core_type ty =
+let parse_native_repr_attributes env core_type ty =
   match core_type.ptyp_desc, (Ctype.repr ty).desc
   with
   | Ptyp_constr ({txt = Ldot(Ldot(Lident "Js", "Fn"),_)}, [{ptyp_desc = Ptyp_arrow (_, _, ct2)}]),
     Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[{desc = Tarrow (_, _, t2, _)}],_) ->
-    let is_internal_primitive = match valdecl.pval_prim with
-      | [ s ] -> s <> "" && (s.[0] = '%' || s.[0] = '?')
-      | _ -> false in
     let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in
-    let native_repr_args =
-      if is_internal_primitive then
-        Same_as_ocaml_repr :: repr_args (* uncurried primitives treated like curried ones *)
-      else [] (* uncurried externals are treated specially by the back-end *) in
+    let native_repr_args = Same_as_ocaml_repr :: repr_args in
     (native_repr_args, repr_res)
   | _ -> parse_native_repr_attributes env core_type ty
 
@@ -1620,7 +1614,7 @@ let transl_value_decl env loc valdecl =
             else Primitive.Same_as_ocaml_repr :: make (n - 1)
           in 
             match scann valdecl.pval_attributes with 
-            | None ->  parse_native_repr_attributes valdecl env valdecl.pval_type ty 
+            | None ->  parse_native_repr_attributes env valdecl.pval_type ty 
             | Some x -> make x , Primitive.Same_as_ocaml_repr
       in
       let prim =

jscomp/test/UncurriedExternals.js

@@ -11,19 +11,36 @@ function dd(param) {
 var h = sum(1.0, 2.0);
 
 var M = {
-  sum: sum
+  sum: (function (prim0, prim1) {
+      return sum(prim0, prim1);
+    })
 };
 
 var hh = M.sum(1.0, 2.0);
 
 var mf = 3 % 4;
 
+function tg(arr) {
+  return arr[0];
+}
+
+var tc = Object.assign({}, "abc");
+
+var te = (function (prim) {
+      return prim;
+    })({
+      RE_EXN_ID: "Not_found"
+    });
+
 var StandardNotation = {
   dd: dd,
   h: h,
   M: M,
   hh: hh,
-  mf: mf
+  mf: mf,
+  tg: tg,
+  tc: tc,
+  te: te
 };
 
 function dd$1(param) {
@@ -36,17 +53,34 @@ function dd$1(param) {
 var h$1 = sum(1.0, 2.0);
 
 var M$1 = {
-  sum: sum
+  sum: (function (prim0, prim1) {
+      return sum(prim0, prim1);
+    })
 };
 
 var hh$1 = M$1.sum(1.0, 2.0);
 
 var mf$1 = 3 % 4;
 
+function tg$1(arr) {
+  return arr[0];
+}
+
+var tc$1 = Object.assign({}, "abc");
+
+var te$1 = (function (prim) {
+      return prim;
+    })({
+      RE_EXN_ID: "Not_found"
+    });
+
 exports.StandardNotation = StandardNotation;
 exports.dd = dd$1;
 exports.h = h$1;
 exports.M = M$1;
 exports.hh = hh$1;
 exports.mf = mf$1;
+exports.tg = tg$1;
+exports.tc = tc$1;
+exports.te = te$1;
 /* h Not a pure module */

jscomp/test/UncurriedExternals.res

@@ -12,8 +12,17 @@ module StandardNotation = {
   }
   let hh = M.sum(. 1.0, 2.0)
 
-  external mod_float : (. float, float) => float = "?fmod_float"
+  external mod_float: (. float, float) => float = "?fmod_float"
   let mf = mod_float(. 3., 4.)
+
+  @get_index external get: (. array<string>, int) => option<'a> = ""
+  let tg = arr => arr->get(. 0)
+
+  @val external copy: (. @as(json`{}`) _, string) => string = "Object.assign"
+  let tc = copy(. "abc")
+
+  external toException: (. exn) => exn = "%identity"
+  let te = toException(. Not_found)
 }
 
 @@uncurried
@@ -31,5 +40,14 @@ module M: {
 }
 let hh = M.sum(1.0, 2.0)
 
-external mod_float : (float, float) => float = "?fmod_float"
+external mod_float: (float, float) => float = "?fmod_float"
 let mf = mod_float(3., 4.)
+
+@get_index external get: (array<string>, int) => option<'a> = ""
+let tg = arr => arr->get(0)
+
+@val external copy: (@as(json`{}`) _, string) => string = "Object.assign"
+let tc = copy("abc")
+
+external toException: exn => exn = "%identity"
+let te = toException(Not_found)

jscomp/test/bs_rest_test.js

@@ -8,7 +8,9 @@ x("3");
 
 var v = x(3);
 
-var xxx = x;
+function xxx(prim) {
+  return x(prim);
+}
 
 var u = xxx(3);
 

lib/4.06.1/unstable/js_compiler.ml

@@ -39167,19 +39167,13 @@ let rec parse_native_repr_attributes env core_type ty =
   | _ -> ([], Same_as_ocaml_repr)
 
 
-let parse_native_repr_attributes valdecl env core_type ty =
+let parse_native_repr_attributes env core_type ty =
   match core_type.ptyp_desc, (Ctype.repr ty).desc
   with
   | Ptyp_constr ({txt = Ldot(Ldot(Lident "Js", "Fn"),_)}, [{ptyp_desc = Ptyp_arrow (_, _, ct2)}]),
     Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[{desc = Tarrow (_, _, t2, _)}],_) ->
-    let is_internal_primitive = match valdecl.pval_prim with
-      | [ s ] -> s <> "" && (s.[0] = '%' || s.[0] = '?')
-      | _ -> false in
     let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in
-    let native_repr_args =
-      if is_internal_primitive then
-        Same_as_ocaml_repr :: repr_args (* uncurried primitives treated like curried ones *)
-      else [] (* uncurried externals are treated specially by the back-end *) in
+    let native_repr_args = Same_as_ocaml_repr :: repr_args in
     (native_repr_args, repr_res)
   | _ -> parse_native_repr_attributes env core_type ty
 
@@ -39211,7 +39205,7 @@ let transl_value_decl env loc valdecl =
             else Primitive.Same_as_ocaml_repr :: make (n - 1)
           in 
             match scann valdecl.pval_attributes with 
-            | None ->  parse_native_repr_attributes valdecl env valdecl.pval_type ty 
+            | None ->  parse_native_repr_attributes env valdecl.pval_type ty 
             | Some x -> make x , Primitive.Same_as_ocaml_repr
       in
       let prim =
@@ -143704,7 +143698,11 @@ let get_uncurry_arity (ty : t) =
   | Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1)
   | _ -> None
 
-let get_curry_arity ty = get_uncurry_arity_aux ty 0
+let get_curry_arity (ty : t) =
+  match ty.ptyp_desc with
+  | Ptyp_constr ({ txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, [ t ]) ->
+      get_uncurry_arity_aux t 0
+  | _ -> get_uncurry_arity_aux ty 0
 
 (* add hoc for bs.send.pipe *)
 let rec get_curry_labels (ty : t) acc =
@@ -143713,7 +143711,6 @@ let rec get_curry_labels (ty : t) acc =
   | _ -> acc
 
 let get_curry_labels ty = List.rev (get_curry_labels ty [])
-
 let is_arity_one ty = get_curry_arity ty = 1
 
 type param_type = {
@@ -149687,6 +149684,15 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     Location.raise_errorf ~loc
       "%@uncurry can not be applied to the whole definition";
   let prim_name_with_source = { name = prim_name; source = External } in
+  let type_annotation, build_uncurried_type = match type_annotation.ptyp_desc with
+    | Ptyp_constr ({txt = Ldot(Ldot(Lident "Js", "Fn"), arity_);_} as lid, [t]) ->
+      t, fun ~arity x ->
+          let arity = match arity with
+            | Some arity -> "arity" ^ string_of_int arity
+            | None -> arity_ in
+          let lid = {lid with txt = Longident.Ldot(Ldot(Lident "Js", "Fn"), arity)} in
+          {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x])}
+    | _ -> type_annotation, fun ~arity:_ x -> x in
   let result_type, arg_types_ty =
     (* Note this assumes external type is syntatic (no abstraction)*)
     Ast_core_type.list_of_arrow type_annotation
@@ -149704,7 +149710,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     let new_type, spec =
       process_obj loc external_desc prim_name arg_types_ty result_type
     in
-    (new_type, spec, unused_attrs, false)
+    (build_uncurried_type ~arity:None new_type, spec, unused_attrs, false)
   else
     let splice = external_desc.splice in
     let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
@@ -149775,7 +149781,8 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     let return_wrapper =
       check_return_wrapper loc external_desc.return_wrapper result_type
     in
-    ( Ast_core_type.mk_fn_type new_arg_types_ty result_type,
+    let fn_type = Ast_core_type.mk_fn_type new_arg_types_ty result_type in
+    ( build_uncurried_type ~arity:(Some (List.length new_arg_types_ty)) fn_type,
       External_ffi_types.ffi_bs arg_type_specs return_wrapper ffi,
       unused_attrs,
       relative )

lib/4.06.1/unstable/js_playground_compiler.ml

@@ -39167,19 +39167,13 @@ let rec parse_native_repr_attributes env core_type ty =
   | _ -> ([], Same_as_ocaml_repr)
 
 
-let parse_native_repr_attributes valdecl env core_type ty =
+let parse_native_repr_attributes env core_type ty =
   match core_type.ptyp_desc, (Ctype.repr ty).desc
   with
   | Ptyp_constr ({txt = Ldot(Ldot(Lident "Js", "Fn"),_)}, [{ptyp_desc = Ptyp_arrow (_, _, ct2)}]),
     Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[{desc = Tarrow (_, _, t2, _)}],_) ->
-    let is_internal_primitive = match valdecl.pval_prim with
-      | [ s ] -> s <> "" && (s.[0] = '%' || s.[0] = '?')
-      | _ -> false in
     let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in
-    let native_repr_args =
-      if is_internal_primitive then
-        Same_as_ocaml_repr :: repr_args (* uncurried primitives treated like curried ones *)
-      else [] (* uncurried externals are treated specially by the back-end *) in
+    let native_repr_args = Same_as_ocaml_repr :: repr_args in
     (native_repr_args, repr_res)
   | _ -> parse_native_repr_attributes env core_type ty
 
@@ -39211,7 +39205,7 @@ let transl_value_decl env loc valdecl =
             else Primitive.Same_as_ocaml_repr :: make (n - 1)
           in 
             match scann valdecl.pval_attributes with 
-            | None ->  parse_native_repr_attributes valdecl env valdecl.pval_type ty 
+            | None ->  parse_native_repr_attributes env valdecl.pval_type ty 
             | Some x -> make x , Primitive.Same_as_ocaml_repr
       in
       let prim =
@@ -143704,7 +143698,11 @@ let get_uncurry_arity (ty : t) =
   | Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1)
   | _ -> None
 
-let get_curry_arity ty = get_uncurry_arity_aux ty 0
+let get_curry_arity (ty : t) =
+  match ty.ptyp_desc with
+  | Ptyp_constr ({ txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, [ t ]) ->
+      get_uncurry_arity_aux t 0
+  | _ -> get_uncurry_arity_aux ty 0
 
 (* add hoc for bs.send.pipe *)
 let rec get_curry_labels (ty : t) acc =
@@ -143713,7 +143711,6 @@ let rec get_curry_labels (ty : t) acc =
   | _ -> acc
 
 let get_curry_labels ty = List.rev (get_curry_labels ty [])
-
 let is_arity_one ty = get_curry_arity ty = 1
 
 type param_type = {
@@ -149687,6 +149684,15 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     Location.raise_errorf ~loc
       "%@uncurry can not be applied to the whole definition";
   let prim_name_with_source = { name = prim_name; source = External } in
+  let type_annotation, build_uncurried_type = match type_annotation.ptyp_desc with
+    | Ptyp_constr ({txt = Ldot(Ldot(Lident "Js", "Fn"), arity_);_} as lid, [t]) ->
+      t, fun ~arity x ->
+          let arity = match arity with
+            | Some arity -> "arity" ^ string_of_int arity
+            | None -> arity_ in
+          let lid = {lid with txt = Longident.Ldot(Ldot(Lident "Js", "Fn"), arity)} in
+          {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x])}
+    | _ -> type_annotation, fun ~arity:_ x -> x in
   let result_type, arg_types_ty =
     (* Note this assumes external type is syntatic (no abstraction)*)
     Ast_core_type.list_of_arrow type_annotation
@@ -149704,7 +149710,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     let new_type, spec =
       process_obj loc external_desc prim_name arg_types_ty result_type
     in
-    (new_type, spec, unused_attrs, false)
+    (build_uncurried_type ~arity:None new_type, spec, unused_attrs, false)
   else
     let splice = external_desc.splice in
     let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
@@ -149775,7 +149781,8 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     let return_wrapper =
       check_return_wrapper loc external_desc.return_wrapper result_type
     in
-    ( Ast_core_type.mk_fn_type new_arg_types_ty result_type,
+    let fn_type = Ast_core_type.mk_fn_type new_arg_types_ty result_type in
+    ( build_uncurried_type ~arity:(Some (List.length new_arg_types_ty)) fn_type,
       External_ffi_types.ffi_bs arg_type_specs return_wrapper ffi,
       unused_attrs,
       relative )