From 4cc6291e3591072cb3bb5bc51cd5b031d3601e97 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 20 Nov 2022 09:10:56 +0100 Subject: [PATCH] Add support for uncurried @this Both in types in externals and in function definitions, the `@this` annotation now ignores uncurried types. In any case, the processing replaces the type (and the function definition) with some internal representation of method types (and of methods). This is so when switching to uncurried mode, the code does not need changing. --- CHANGELOG.md | 2 +- jscomp/frontend/ast_core_type_class_type.ml | 7 +++- jscomp/frontend/bs_builtin_ppx.ml | 11 ++++++ jscomp/test/UncurriedExternals.js | 34 ++++++++++++++++++- jscomp/test/UncurriedExternals.res | 12 +++++++ lib/4.06.1/unstable/js_compiler.ml | 18 +++++++++- lib/4.06.1/unstable/js_playground_compiler.ml | 18 +++++++++- lib/4.06.1/whole_compiler.ml | 18 +++++++++- 8 files changed, 114 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f603f2ce72..13ca1e2f69 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 https://github.com/rescript-lang/rescript-compiler/pull/5819 +- Add support for uncurried externals https://github.com/rescript-lang/rescript-compiler/pull/5815 https://github.com/rescript-lang/rescript-compiler/pull/5819 https://github.com/rescript-lang/rescript-compiler/pull/5830 - Parser/Printer: unify uncurried functions of arity 0, and of arity 1 taking unit. There's now only arity 1 in the source language. https://github.com/rescript-lang/rescript-compiler/pull/5825 diff --git a/jscomp/frontend/ast_core_type_class_type.ml b/jscomp/frontend/ast_core_type_class_type.ml index 9169f1b7ae..38d5e6c41e 100644 --- a/jscomp/frontend/ast_core_type_class_type.ml +++ b/jscomp/frontend/ast_core_type_class_type.ml @@ -122,7 +122,12 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = match ty with | { ptyp_attributes; - ptyp_desc = Ptyp_arrow (label, args, body); + ptyp_desc = + ( Ptyp_arrow (label, args, body) + | Ptyp_constr + (* Js.Fn.xx is re-wrapped around only in case Nothing below *) + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + [ { ptyp_desc = Ptyp_arrow (label, args, body) } ] ) ); (* let it go without regard label names, it will report error later when the label is not empty *) diff --git a/jscomp/frontend/bs_builtin_ppx.ml b/jscomp/frontend/bs_builtin_ppx.ml index d1499b0410..ef3104e8e0 100644 --- a/jscomp/frontend/bs_builtin_ppx.ml +++ b/jscomp/frontend/bs_builtin_ppx.ml @@ -115,6 +115,17 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) | true, pexp_attributes -> Ast_bs_open.convertBsErrorFunction e.pexp_loc self pexp_attributes cases) + | Pexp_record + ( [ + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + ({ pexp_desc = Pexp_fun _; pexp_attributes } as inner_exp) ); + ], + None ) + when match Ast_attributes.process_attributes_rev pexp_attributes with + | Meth_callback _, _ -> true + | _ -> false -> + (* Treat @this (. x, y, z) => ... just like @this (x, y, z) => ... *) + self.expr self inner_exp | Pexp_fun (label, _, pat, body) -> ( let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in match Ast_attributes.process_attributes_rev e.pexp_attributes with diff --git a/jscomp/test/UncurriedExternals.js b/jscomp/test/UncurriedExternals.js index 2ad6c4a52d..0f0aa5bfe4 100644 --- a/jscomp/test/UncurriedExternals.js +++ b/jscomp/test/UncurriedExternals.js @@ -34,6 +34,20 @@ var te = (function (prim) { var tcr = {}; +function tsiC(c) { + c.increment = (function (amount) { + var me = this ; + console.log(me); + }); +} + +function tsiU(c) { + c.increment = (function (amount) { + var me = this ; + console.log(me); + }); +} + var StandardNotation = { dd: dd, h: h, @@ -43,7 +57,9 @@ var StandardNotation = { tg: tg, tc: tc, te: te, - tcr: tcr + tcr: tcr, + tsiC: tsiC, + tsiU: tsiU }; function dd$1(param) { @@ -79,6 +95,20 @@ var te$1 = (function (prim) { var tcr$1 = {}; +function tsiC$1(c) { + c.increment = (function (amount) { + var me = this ; + console.log(me); + }); +} + +function tsiU$1(c) { + c.increment = (function (amount) { + var me = this ; + console.log(me); + }); +} + exports.StandardNotation = StandardNotation; exports.dd = dd$1; exports.h = h$1; @@ -89,4 +119,6 @@ exports.tg = tg$1; exports.tc = tc$1; exports.te = te$1; exports.tcr = tcr$1; +exports.tsiC = tsiC$1; +exports.tsiU = tsiU$1; /* h Not a pure module */ diff --git a/jscomp/test/UncurriedExternals.res b/jscomp/test/UncurriedExternals.res index befcde30a8..c3795352d1 100644 --- a/jscomp/test/UncurriedExternals.res +++ b/jscomp/test/UncurriedExternals.res @@ -26,6 +26,12 @@ module StandardNotation = { @obj external ccreate : (. unit) => string = "" let tcr = ccreate(.) + + type counter + @set external setIncrementC: (counter, @this (counter, int) => unit) => unit = "increment" + let tsiC = c => setIncrementC(c, @this (me, amount) => Js.log(me)) + @set external setIncrementU: (. counter, @this (. counter, int) => unit) => unit = "increment" + let tsiU = c => setIncrementU(. c, @this (. me, amount) => Js.log(me)) } @@uncurried @@ -57,3 +63,9 @@ let te = toException(Not_found) @obj external ucreate : unit => string = "" let tcr = ucreate() + +type counter +@set external setIncrementC: (. counter, @this (. counter, int) => unit) => unit = "increment" +let tsiC = c => setIncrementC(. c, @this (. me, amount) => Js.log(. me)) +@set external setIncrementU: (counter, @this (counter, int) => unit) => unit = "increment" +let tsiU = c => setIncrementU(c, @this (me, amount) => Js.log(. me)) diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index dc4736fcd8..eebdfc6b46 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -146937,7 +146937,12 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = match ty with | { ptyp_attributes; - ptyp_desc = Ptyp_arrow (label, args, body); + ptyp_desc = + ( Ptyp_arrow (label, args, body) + | Ptyp_constr + (* Js.Fn.xx is re-wrapped around only in case Nothing below *) + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + [ { ptyp_desc = Ptyp_arrow (label, args, body) } ] ) ); (* let it go without regard label names, it will report error later when the label is not empty *) @@ -152110,6 +152115,17 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) | true, pexp_attributes -> Ast_bs_open.convertBsErrorFunction e.pexp_loc self pexp_attributes cases) + | Pexp_record + ( [ + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + ({ pexp_desc = Pexp_fun _; pexp_attributes } as inner_exp) ); + ], + None ) + when match Ast_attributes.process_attributes_rev pexp_attributes with + | Meth_callback _, _ -> true + | _ -> false -> + (* Treat @this (. x, y, z) => ... just like @this (x, y, z) => ... *) + self.expr self inner_exp | Pexp_fun (label, _, pat, body) -> ( let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in match Ast_attributes.process_attributes_rev e.pexp_attributes with diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index e770e16478..20bdb12fce 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -146937,7 +146937,12 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = match ty with | { ptyp_attributes; - ptyp_desc = Ptyp_arrow (label, args, body); + ptyp_desc = + ( Ptyp_arrow (label, args, body) + | Ptyp_constr + (* Js.Fn.xx is re-wrapped around only in case Nothing below *) + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + [ { ptyp_desc = Ptyp_arrow (label, args, body) } ] ) ); (* let it go without regard label names, it will report error later when the label is not empty *) @@ -152110,6 +152115,17 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) | true, pexp_attributes -> Ast_bs_open.convertBsErrorFunction e.pexp_loc self pexp_attributes cases) + | Pexp_record + ( [ + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + ({ pexp_desc = Pexp_fun _; pexp_attributes } as inner_exp) ); + ], + None ) + when match Ast_attributes.process_attributes_rev pexp_attributes with + | Meth_callback _, _ -> true + | _ -> false -> + (* Treat @this (. x, y, z) => ... just like @this (x, y, z) => ... *) + self.expr self inner_exp | Pexp_fun (label, _, pat, body) -> ( let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in match Ast_attributes.process_attributes_rev e.pexp_attributes with diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 66f6cbe8ed..fc861bf8c1 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -157221,7 +157221,12 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = match ty with | { ptyp_attributes; - ptyp_desc = Ptyp_arrow (label, args, body); + ptyp_desc = + ( Ptyp_arrow (label, args, body) + | Ptyp_constr + (* Js.Fn.xx is re-wrapped around only in case Nothing below *) + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + [ { ptyp_desc = Ptyp_arrow (label, args, body) } ] ) ); (* let it go without regard label names, it will report error later when the label is not empty *) @@ -162394,6 +162399,17 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) | true, pexp_attributes -> Ast_bs_open.convertBsErrorFunction e.pexp_loc self pexp_attributes cases) + | Pexp_record + ( [ + ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, + ({ pexp_desc = Pexp_fun _; pexp_attributes } as inner_exp) ); + ], + None ) + when match Ast_attributes.process_attributes_rev pexp_attributes with + | Meth_callback _, _ -> true + | _ -> false -> + (* Treat @this (. x, y, z) => ... just like @this (x, y, z) => ... *) + self.expr self inner_exp | Pexp_fun (label, _, pat, body) -> ( let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in match Ast_attributes.process_attributes_rev e.pexp_attributes with