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.

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 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
 
 

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
    *)

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

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 */

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))

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

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

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