diff --git a/CHANGELOG.md b/CHANGELOG.md index 693dbe0174..49794546ce 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/jscomp/frontend/ast_core_type.ml b/jscomp/frontend/ast_core_type.ml index 910c23d0ad..ed83c627fc 100644 --- a/jscomp/frontend/ast_core_type.ml +++ b/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 = { diff --git a/jscomp/frontend/ast_external_process.ml b/jscomp/frontend/ast_external_process.ml index d381a8a876..202735f6e9 100644 --- a/jscomp/frontend/ast_external_process.ml +++ b/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 ) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index a792fd4d4f..2e5ee8a642 100644 --- a/jscomp/ml/typedecl.ml +++ b/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 = diff --git a/jscomp/test/UncurriedExternals.js b/jscomp/test/UncurriedExternals.js index aed2892465..2feda2f6d5 100644 --- a/jscomp/test/UncurriedExternals.js +++ b/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 */ diff --git a/jscomp/test/UncurriedExternals.res b/jscomp/test/UncurriedExternals.res index e3e10ce1c8..e09a2faece 100644 --- a/jscomp/test/UncurriedExternals.res +++ b/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, 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, 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) diff --git a/jscomp/test/bs_rest_test.js b/jscomp/test/bs_rest_test.js index a6e7955afa..8692d0540b 100644 --- a/jscomp/test/bs_rest_test.js +++ b/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); diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 066d41ee08..bd08bab558 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/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 ) diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index ee6a044660..a9a663e830 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/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 ) diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 383659c7df..e1dca0f909 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -55063,7 +55063,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 = @@ -55072,7 +55076,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 = { @@ -94162,19 +94165,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 @@ -94206,7 +94203,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 = @@ -159971,6 +159968,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 @@ -159988,7 +159994,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 = @@ -160059,7 +160065,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 )