Support @new @variadic

Signed-off-by: Yuta Sato <cannorin@users.noreply.github.com>

Author: cannorin

Changes.md

@@ -4,6 +4,8 @@
 
 **Compiler**
 
+- #5364 support `@new @variadic`
+
 **Syntax**
 
 **Playground**

jscomp/core/lam_compile_external_call.ml

@@ -26,11 +26,15 @@
 
 module E = Js_exp_make
 
-let splice_fn_apply fn args =
+let splice_apply fn args =
   E.runtime_call Js_runtime_modules.caml_splice_call "spliceApply"
     [ fn; E.array Immutable args ]
 
-let splice_obj_fn_apply obj name args =
+let splice_new_apply fn args =
+  E.runtime_call Js_runtime_modules.caml_splice_call "spliceNewApply"
+    [ fn; E.array Immutable args ]
+
+let splice_obj_apply obj name args =
   E.runtime_call Js_runtime_modules.caml_splice_call "spliceObjApply"
     [ obj; E.str name; E.array Immutable args ]
 
@@ -253,7 +257,7 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
       if splice then
         let args, eff, dynamic = assemble_args_has_splice arg_types args in
         add_eff eff
-          (if dynamic then splice_fn_apply fn args
+          (if dynamic then splice_apply fn args
           else E.call ~info:{ arity = Full; call_info = Call_na } fn args)
       else
         let args, eff = assemble_args_no_splice arg_types args in
@@ -265,13 +269,13 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
         let args, eff, dynamic = assemble_args_has_splice arg_types args in
         (* TODO: fix in rest calling convention *)
         add_eff eff
-          (if dynamic then splice_fn_apply fn args
+          (if dynamic then splice_apply fn args
           else E.call ~info:{ arity = Full; call_info = Call_na } fn args)
       else
         let args, eff = assemble_args_no_splice arg_types args in
         (* TODO: fix in rest calling convention *)
         add_eff eff (E.call ~info:{ arity = Full; call_info = Call_na } fn args)
-  | Js_new { external_module_name = module_name; name = fn; scopes } ->
+  | Js_new { external_module_name = module_name; name = fn; splice; scopes } ->
       (* handle [@@new]*)
       (* This has some side effect, it will
          mark its identifier (If it has) as an object,
@@ -281,15 +285,25 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
          TODO: we should propagate this property
          as much as we can(in alias table)
       *)
-      let args, eff = assemble_args_no_splice arg_types args in
-      let fn = translate_scoped_module_val module_name fn scopes in
-      add_eff eff
-        ((match cxt.continuation with
+      let mark () =
+        match cxt.continuation with
          | Declare (_, id) | Assign id ->
              (* Format.fprintf Format.err_formatter "%a@."Ident.print  id; *)
              Ext_ident.make_js_object id
-         | EffectCall _ | NeedValue _ -> ());
-         E.new_ fn args)
+        | EffectCall _ | NeedValue _ -> ()
+      in
+      if splice then
+        let args, eff, dynamic = assemble_args_has_splice arg_types args in
+        let fn = translate_scoped_module_val module_name fn scopes in
+        add_eff eff
+          (mark ();
+          if dynamic then splice_new_apply fn args
+          else E.new_ fn args)
+      else
+        let args, eff = assemble_args_no_splice arg_types args in
+        let fn = translate_scoped_module_val module_name fn scopes in
+        add_eff eff
+          (mark (); E.new_ fn args)
   | Js_send { splice; name; js_send_scopes } -> (
       match args with
       | self :: args ->
@@ -300,7 +314,7 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
             let args, eff, dynamic = assemble_args_has_splice arg_types args in
             add_eff eff
               (let self = translate_scoped_access js_send_scopes self in
-               if dynamic then splice_obj_fn_apply self name args
+               if dynamic then splice_obj_apply self name args
                else
                  E.call
                    ~info:{ arity = Full; call_info = Call_na }

jscomp/frontend/ast_external_process.ml

@@ -800,12 +800,12 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    val_send = None;
    set_name = None;
    get_name = None;
-   splice = false;
+   splice;
    scopes;
    mk_obj = _;
    return_wrapper = _;
   } ->
-      Js_new { name; external_module_name; scopes }
+      Js_new { name; external_module_name; splice; scopes }
   | { new_name = Some _; _ } ->
       Bs_syntaxerr.err loc
         (Conflict_ffi_attribute "Attribute found that conflicts with %@new")

jscomp/frontend/external_ffi_types.ml

@@ -72,6 +72,7 @@ type external_spec =
   | Js_new of {
       name : string ;
       external_module_name : external_module_name option;
+      splice : bool ;
       scopes : string list;
     }
   | Js_set of { 
@@ -224,7 +225,7 @@ let check_ffi ?loc ffi : bool =
       -> 
       upgrade (is_package_relative_path external_module_name.bundle);
       check_external_module_name external_module_name
-    | Js_new {external_module_name ;  name; scopes = _}
+    | Js_new {external_module_name ;  name; splice = _; scopes = _}
     | Js_call {external_module_name ;  name ; splice = _; scopes = _ }
       ->
       Ext_option.iter external_module_name (fun external_module_name ->
@@ -266,10 +267,10 @@ let is_bs_primitive s =
 
 let () = Oprint.map_primitive_name := 
 
-# 272 "frontend/external_ffi_types.pp.ml"
+# 273 "frontend/external_ffi_types.pp.ml"
       String.escaped
 
-# 275 "frontend/external_ffi_types.pp.ml"
+# 276 "frontend/external_ffi_types.pp.ml"
 (* TODO:  better error message when version mismatch *)
 let from_string s : t =
   if is_bs_primitive s  then   

jscomp/frontend/external_ffi_types.mli

@@ -58,6 +58,7 @@ type external_spec =
   | Js_new of {
       name : string;
       external_module_name : external_module_name option;
+      splice : bool;
       scopes : string list;
     }
   | Js_set of { js_set_name : string; js_set_scopes : string list }

jscomp/frontend/external_ffi_types.pp.ml

@@ -71,6 +71,7 @@ type external_spec =
   | Js_new of {
       name : string ;
       external_module_name : external_module_name option;
+      splice : bool ;
       scopes : string list;
     }
   | Js_set of { 
@@ -223,7 +224,7 @@ let check_ffi ?loc ffi : bool =
       -> 
       upgrade (is_package_relative_path external_module_name.bundle);
       check_external_module_name external_module_name
-    | Js_new {external_module_name ;  name; scopes = _}
+    | Js_new {external_module_name ;  name; splice = _; scopes = _}
     | Js_call {external_module_name ;  name ; splice = _; scopes = _ }
       ->
       Ext_option.iter external_module_name (fun external_module_name ->

jscomp/runtime/caml_splice_call.ml

@@ -38,6 +38,21 @@ let spliceApply : obj -> obj -> obj = [%raw{|function(fn,args){
   return fn.apply(null,applied)
 }|}] 
 
+let spliceNewApply : obj -> obj -> obj = [%raw{|function (ctor,args){
+  var i, argLen;
+  argLen = args.length
+  var applied = [null] // Function.prototype.bind.apply(fn, args) requires the first element in `args` to be `null`
+  for(i = 0; i < argLen - 1; ++i){
+    applied.push(args[i])
+  }
+  var lastOne = args[argLen - 1]
+  for(i = 0; i < lastOne.length; ++i ){
+    applied.push(lastOne[i])
+  }
+  var C = Function.prototype.bind.apply(ctor, applied)
+  return new C()
+}|}]
+
 let spliceObjApply : obj -> obj -> obj -> obj = [%raw{|function(obj,name,args){
   var i, argLen; 
   argLen = args.length

jscomp/runtime/caml_splice_call.mli

@@ -27,4 +27,6 @@ type obj = Obj.t
 
 val spliceApply : obj -> obj -> obj
 
+val spliceNewApply : obj -> obj -> obj
+
 val spliceObjApply : obj -> obj -> obj -> obj

jscomp/test/splice_test.ml

@@ -37,6 +37,50 @@ let dynamic arr =
 ;; dynamic [||]
 ;; dynamic [|1;1;3|]
 
+(* Array constructor with a single parameter `x`
+   just makes an array with its length set to `x`,
+   so at least two parameters are needed
+*)
+external newArr : int -> int -> int array -> int array = "Array"
+  [@@bs.splice] [@@bs.new]
+
+let () =
+  let a = newArr 1 2 [|3;4|] in
+  eq __LOC__ a [|1;2;3;4|]
+
+let dynamicNew arr =
+  let a = newArr 1 2 arr in
+  eq __LOC__ a (Array.concat [[|1; 2|]; arr])
+
+;; dynamicNew [|3;4|]
+;; dynamicNew [||]
+;; dynamicNew [|1;3|]
+
+[%%raw{|
+class Foo {
+  constructor(...names) {
+    this.names = names;
+  }
+}
+|}]
+
+type foo
+
+external newFoo : string array -> foo = "Foo" [@@bs.splice] [@@bs.new]
+external fooNames : foo -> string array = "names" [@@get]
+
+let () =
+  let f = newFoo [|"a";"b";"c"|] in
+  eq __LOC__ (fooNames f) [|"a";"b";"c"|]
+
+let dynamicFoo arr =
+  let f = newFoo arr in
+  eq __LOC__ (fooNames f) arr
+
+;; dynamicFoo [||]
+;; dynamicFoo [|"a"|]
+;; dynamicFoo [|"a";"b";"c"|]
+
 module Pipe = struct
   external push :  int array -> int -> int array -> unit = 
     "push" [@@send] [@@bs.splice]