Fix issues with the arity of externals.

Author: cristianoc

CHANGELOG.md

@@ -20,7 +20,7 @@
 - Allow free vars in types for type coercion `e :> t`. https://github.com/rescript-lang/rescript-compiler/pull/6828
 - Allow `private` in with constraints. https://github.com/rescript-lang/rescript-compiler/pull/6843
 - Add regex literals as syntax sugar for `@bs.re`. https://github.com/rescript-lang/rescript-compiler/pull/6776
-- Improved mechanism to determine arity of externals, which is consistent however the type is written. https://github.com/rescript-lang/rescript-compiler/pull/6874
+- Improved mechanism to determine arity of externals, which is consistent however the type is written. https://github.com/rescript-lang/rescript-compiler/pull/6874 https://github.com/rescript-lang/rescript-compiler/pull/6881
 
 #### :boom: Breaking Change
 

jscomp/core/lam_compile_external_call.ml

@@ -365,7 +365,9 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
          2. support [@@scope "window"]
          we need know whether we should call [add_js_module] or not
       *)
-      translate_scoped_module_val external_module_name name scopes ~dynamic_import
+      let e = translate_scoped_module_val external_module_name name scopes ~dynamic_import in
+      if args = [] then e
+      else E.call ~info:{ arity = Full; call_info = Call_na } e args
   | Js_module_as_class module_name ->
       let fn = external_var module_name ~dynamic_import in
       let args, eff = assemble_args_no_splice arg_types args in

jscomp/frontend/external_ffi_types.ml

@@ -240,7 +240,13 @@ let from_string s : t =
 
 let () =
   Primitive.coerce :=
-    fun ({prim_name; prim_arity; prim_native_name; prim_alloc = _} :
+    fun ({
+           prim_name;
+           prim_arity;
+           prim_native_name;
+           prim_alloc = _;
+           prim_from_constructor = _;
+         } :
           Primitive.description) (p2 : Primitive.description) ->
       let p2_native = p2.prim_native_name in
       prim_name = p2.prim_name && prim_arity = p2.prim_arity

jscomp/ml/primitive.ml

@@ -25,6 +25,7 @@ type description =
     prim_arity: int;           (* Number of arguments *)
     prim_alloc: bool;          (* Does it allocates or raise? *)
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_from_constructor: bool; (* Is it from a type constructor instead of a concrete function type? *)
   }
 
 let coerce : (description -> description -> bool) ref = 
@@ -37,15 +38,17 @@ let simple ~name ~arity ~alloc =
   {prim_name = name;
    prim_arity = arity;
    prim_alloc = alloc;
-   prim_native_name = "";}
+   prim_native_name = "";
+   prim_from_constructor = false;}
 
 let make ~name ~alloc ~native_name ~arity =
   {prim_name = name;
    prim_arity = arity;
    prim_alloc = alloc;
-   prim_native_name = native_name;}
+   prim_native_name = native_name;
+   prim_from_constructor = false;}
 
-let parse_declaration valdecl ~arity =
+let parse_declaration valdecl ~arity ~from_constructor =
   let name, native_name =
     match valdecl.pval_prim with
     | name :: name2 :: _ -> (name, name2)
@@ -56,7 +59,8 @@ let parse_declaration valdecl ~arity =
   {prim_name = name;
    prim_arity = arity;
    prim_alloc = true;
-   prim_native_name = native_name;}
+   prim_native_name = native_name;
+   prim_from_constructor = from_constructor}
 
 open Outcometree
 

jscomp/ml/primitive.mli

@@ -22,6 +22,7 @@ type description = private
     prim_arity: int;           (* Number of arguments *)
     prim_alloc: bool;          (* Does it allocates or raise? *)
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_from_constructor: bool; (* Is it from a type constructor instead of a concrete function type? *)
   }
 
 (* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
@@ -42,6 +43,7 @@ val make
 val parse_declaration
   :  Parsetree.value_description
   -> arity: int
+  -> from_constructor: bool
   -> description
 
 val print

jscomp/ml/translcore.ml

@@ -459,6 +459,7 @@ let specialize_primitive p env ty (* ~has_constant_constructor *) =
 (* Eta-expand a primitive *)
 
 let transl_primitive loc p env ty =
+  (* Printf.eprintf "----transl_primitive %s----\n" p.prim_name; *)
   let prim =
     try specialize_primitive p env ty (* ~has_constant_constructor:false *)
     with Not_found -> Pccall p
@@ -496,7 +497,7 @@ let transl_primitive loc p env ty =
           :: make_params (n - 1) total
       in
       let prim_arity = p.prim_arity in
-      if prim_arity = 0 then Lprim (prim, [], loc)
+      if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc)
       else
         let params =
           if prim_arity = 1 then [ Ident.create "prim" ]

jscomp/ml/typedecl.ml

@@ -1718,8 +1718,10 @@ let rec arity_from_arrow_type env core_type ty =
 
 let parse_arity env core_type ty =
   match Ast_uncurried.uncurried_type_get_arity_opt ~env ty with
-  | Some arity -> arity
-  | None -> arity_from_arrow_type env core_type ty
+  | Some arity ->
+    let from_constructor = Ast_uncurried.uncurried_type_get_arity_opt ~env:Env.empty ty = None in
+    (arity, from_constructor)
+  | None -> (arity_from_arrow_type env core_type ty, false)
 
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
@@ -1733,7 +1735,7 @@ let transl_value_decl env loc valdecl =
   | [] ->
       raise (Error(valdecl.pval_loc, Val_in_structure))
   | _ ->
-      let arity =
+      let arity, from_constructor =
           let rec scan_attributes (attrs : Parsetree.attributes)  = 
             match attrs with 
             | ({txt = "internal.arity";_}, (* This is likely not needed in uncurried mode *)
@@ -1747,9 +1749,9 @@ let transl_value_decl env loc valdecl =
           in 
           match scan_attributes valdecl.pval_attributes with 
           | None ->  parse_arity env valdecl.pval_type ty 
-          | Some x -> x
+          | Some x -> x, false
       in
-      let prim = Primitive.parse_declaration valdecl ~arity in
+      let prim = Primitive.parse_declaration valdecl ~arity ~from_constructor in
       let prim_native_name = prim.prim_native_name in 
       if prim.prim_arity = 0 &&
          not ( String.length prim_native_name >= 20 &&

jscomp/test/ExternalArity.js

@@ -1,8 +1,42 @@
 @@uncurried
 
+@@config({
+  flags: ["-bs-jsx", "4"],
+})
+
 type u = (int, int) => int
 @val external v1: u = "v" // arity from u is implicit
 @val external v2: (int, int) => int = "v" // arity is explicit
 
-let f1 = x => v1(x,x)
-let f2 = x => v2(x,x)
+let f1 = x => v1(x, x)
+let f2 = x => v2(x, x)
+
+module FromTypeConstructor = {
+  type fn<'props, 'return> = 'props => 'return
+
+  external foo1: fn<int, int> = "foo1"
+  let test1 = foo1(10)
+
+  external foo2: int => int = "foo2"
+  let test2 = foo2(20)
+
+  external foo3: (~x: int=?, ~y: int) => int = "foo3"
+  let test3 = foo3(~y=3)
+}
+
+module ReactTest = {
+  module React = {
+    type element = Jsx.element
+    type componentLike<'props, 'return> = 'props => 'return
+    type component<'props> = Jsx.component<'props>
+
+    @module("react/jsx-runtime")
+    external jsx: (component<'props>, 'props) => element = "jsx"
+  }
+
+  module FormattedMessage = {
+    @react.component @module("react-intl")
+    external make: (~id: string, ~defaultMessage: string) => React.element = "FormattedMessage"
+  }
+  let _ = <FormattedMessage id="test" defaultMessage="Test" />
+}