use tagged_template annotation in ffi instead

Author: tsnobip

jscomp/core/lam.ml

@@ -28,7 +28,6 @@ type apply_status = App_na | App_infer_full | App_uncurry
 type ap_info = {
   ap_loc : Location.t;
   ap_inlined : Lambda.inline_attribute;
-  ap_tagged_template : bool;
   ap_status : apply_status;
 }
 

jscomp/core/lam.mli

@@ -27,7 +27,6 @@ type apply_status = App_na | App_infer_full | App_uncurry
 type ap_info = {
   ap_loc : Location.t;
   ap_inlined : Lambda.inline_attribute;
-  ap_tagged_template : bool;
   ap_status : apply_status;
 }
 

jscomp/core/lam_analysis.ml

@@ -98,7 +98,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
           true
       | Pjs_apply | Pjs_runtime_apply | Pjs_call _ | Pinit_mod | Pupdate_mod
       | Pjs_unsafe_downgrade _ | Pdebugger | Pvoid_run | Pfull_apply
-      | Pjs_fn_method  | Pjs_tagged_template _
+      | Pjs_fn_method
       (* TODO *)
       | Praw_js_code _ | Pbytessetu | Pbytessets
       (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)

jscomp/core/lam_compile.ml

@@ -1599,7 +1599,6 @@ and compile_prim (prim_info : Lam.prim_info)
                {
                  ap_loc = loc;
                  ap_inlined = Default_inline;
-                 ap_tagged_template = false;
                  ap_status = App_uncurry;
                })
       (*FIXME: should pass info down: `f a [@bs][@inlined]`*)

jscomp/core/lam_compile_external_call.ml

@@ -252,7 +252,17 @@ let translate_scoped_access scopes obj =
 let translate_ffi (cxt : Lam_compile_context.t) arg_types
     (ffi : External_ffi_types.external_spec) (args : J.expression list) =
   match ffi with
-  | Js_call { external_module_name = module_name; name = fn; splice; scopes } ->
+  | Js_call { external_module_name; name; splice; scopes; tagged_template = true } -> 
+      let fn = translate_scoped_module_val external_module_name name scopes in 
+      (match args with
+      | [ stringArgs; valueArgs ] -> (
+          match (stringArgs, valueArgs) with
+          | ({expression_desc = Array (strings, _); _}, {expression_desc = Array (values, _); _}) ->
+              E.tagged_template fn strings values
+          | _ -> assert false
+          )
+      | _ -> assert false)
+  | Js_call { external_module_name = module_name; name = fn; splice; scopes; tagged_template = false } ->
       let fn = translate_scoped_module_val module_name fn scopes in
       if splice then
         let args, eff, dynamic = assemble_args_has_splice arg_types args in
@@ -381,19 +391,3 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
       | [ obj; v; value ] ->
           Js_arr.set_array (translate_scoped_access scopes obj) v value
       | _ -> assert false)
-
-let translate_tagged_template (cxt : Lam_compile_context.t)
-  (ffi : External_ffi_types.external_spec) (args : J.expression list) = 
-  let fn = match ffi with
-  | Js_call { external_module_name; name; scopes; _ } ->
-      translate_scoped_module_val external_module_name name scopes
-  | _ ->  assert false
-  in
-  match args with
-  | [ stringArgs; valueArgs ] -> (
-      match (stringArgs, valueArgs) with
-      | ({expression_desc = Array (strings, _); _}, {expression_desc = Array (values, _); _}) ->
-          E.tagged_template fn strings values
-      | _ -> assert false
-      )
-  | _ -> assert false

jscomp/core/lam_compile_external_call.mli

@@ -36,12 +36,6 @@ val translate_ffi :
   J.expression list ->
   J.expression
 
-val translate_tagged_template :
-  Lam_compile_context.t ->
-  External_ffi_types.external_spec ->
-  J.expression list ->
-  J.expression
-
 (** TODO: document supported attributes
     Attributes starting with `js` are reserved
     examples: "variadic"

jscomp/core/lam_compile_primitive.ml

@@ -339,7 +339,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
   | Pjs_object_create _ -> assert false
   | Pjs_call { arg_types; ffi } ->
       Lam_compile_external_call.translate_ffi cxt arg_types ffi args
-  | Pjs_tagged_template { ffi } -> Lam_compile_external_call.translate_tagged_template cxt ffi args
   (* FIXME, this can be removed later *)
   | Pisint -> E.is_type_number (Ext_list.singleton_exn args)
   | Pis_poly_var_block -> E.is_type_object (Ext_list.singleton_exn args)

jscomp/core/lam_convert.ml

@@ -512,11 +512,11 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
     match lam with
     | Lvar x -> Lam.var (Hash_ident.find_default alias_tbl x x)
     | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x)
-    | Lapply { ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined; ap_tagged_template } ->
+    | Lapply { ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined } ->
         (* we need do this eargly in case [aux fn] add some wrapper *)
         Lam.apply (convert_aux fn)
           (Ext_list.map args convert_aux)
-          { ap_loc = loc; ap_inlined; ap_tagged_template; ap_status = App_na }
+          { ap_loc = loc; ap_inlined; ap_status = App_na }
     | Lfunction { params; body; attr } ->
         let new_map, body =
           rename_optional_parameters Map_ident.empty params body
@@ -685,15 +685,13 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
           {
             ap_loc = outer_loc;
             ap_inlined = ap_info.ap_inlined;
-            ap_tagged_template = ap_info.ap_tagged_template;
             ap_status = App_na;
           }
     | _ ->
         Lam.apply f [ x ]
           {
             ap_loc = outer_loc;
             ap_inlined = Default_inline;
-            ap_tagged_template = false;
             ap_status = App_na;
           }
   and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) =

jscomp/core/lam_eta_conversion.ml

@@ -111,7 +111,7 @@ let transform_under_supply n ap_info fn args =
 let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) :
     Lam.t =
   let ap_info : Lam.ap_info =
-    { ap_loc = loc; ap_inlined = Default_inline; ap_tagged_template = false; ap_status = App_na }
+    { ap_loc = loc; ap_inlined = Default_inline; ap_status = App_na }
   in
   let is_async_fn = match fn with
     | Lfunction { attr = {async}} -> async 

jscomp/core/lam_pass_remove_alias.ml

@@ -198,7 +198,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
 
         (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp;     *)
         let ap_args = Ext_list.map ap_args simpl in
-        let normal () = Lam.apply (simpl fn) ap_args ap_info in
+        let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in
         match Hash_ident.find_opt meta.ident_tbl v with
         | Some
             (FunctionId
@@ -238,7 +238,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
                   Lam_closure.is_closed_with_map meta.export_idents params body
                 in
                 let is_export_id = Set_ident.mem meta.export_idents v in
-                let result = match (is_export_id, param_map) with
+                match (is_export_id, param_map) with
                 | false, (_, param_map) | true, (true, param_map) -> (
                     match rec_flag with
                     | Lam_rec ->
@@ -256,18 +256,6 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
                             (Lam_beta_reduce.propagate_beta_reduce_with_map meta
                                param_map params body ap_args))
                 | _ -> normal ()
-                in
-                let result = (match result with
-                | Lprim {primitive; args; loc} -> (match primitive with
-                  (* Converts Pjs_calls to Pjs_tagged_templates if ap_tagged_template is true *)
-                  | Pjs_call {prim_name; ffi} when ap_info.ap_tagged_template ->
-                    let prim = Lam_primitive.Pjs_tagged_template {prim_name; ffi} in
-                    Lam.prim ~primitive:prim ~args loc
-                  | _ -> result
-                  )
-                | _ -> result)
-                in
-                result
               else normal ()
             else normal ()
         | Some _ | None -> normal ())

jscomp/core/lam_primitive.ml

@@ -49,10 +49,6 @@ type t =
       arg_types : External_arg_spec.params;
       ffi : External_ffi_types.external_spec;
     }
-  | Pjs_tagged_template of { 
-      prim_name : string;
-      ffi : External_ffi_types.external_spec;
-    }
   | Pjs_object_create of External_arg_spec.obj_params
   (* Exceptions *)
   | Praise
@@ -263,11 +259,6 @@ let eq_primitive_approx (lhs : t) (rhs : t) =
       match rhs with
       | Pjs_object_create obj_create1 -> obj_create = obj_create1
       | _ -> false)
-  | Pjs_tagged_template { prim_name; ffi } -> (
-       match rhs with
-      | Pjs_tagged_template rhs ->
-          prim_name = rhs.prim_name && ffi = rhs.ffi
-      | _ -> false)
   | Pintcomp comparison -> (
       match rhs with
       | Pintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1

jscomp/core/lam_primitive.mli

@@ -44,10 +44,6 @@ type t =
       arg_types : External_arg_spec.params;
       ffi : External_ffi_types.external_spec;
     }
-  | Pjs_tagged_template of {
-      prim_name : string;
-      ffi : External_ffi_types.external_spec;
-    }
   | Pjs_object_create of External_arg_spec.obj_params
   | Praise
   | Psequand

jscomp/core/lam_print.ml

@@ -93,7 +93,6 @@ let primitive ppf (prim : Lam_primitive.t) =
   | Plazyforce -> fprintf ppf "force"
   | Pccall p -> fprintf ppf "%s" p.prim_name
   | Pjs_call { prim_name } -> fprintf ppf "%s[js]" prim_name
-  | Pjs_tagged_template { prim_name } -> fprintf ppf "%s[js.tagged_template]" prim_name
   | Pjs_object_create _ -> fprintf ppf "[js.obj]"
   | Praise -> fprintf ppf "raise"
   | Psequand -> fprintf ppf "&&"
@@ -264,13 +263,12 @@ let lambda ppf v =
     | Lvar id -> Ident.print ppf id
     | Lglobal_module (id, dynamic_import) -> fprintf ppf (if dynamic_import then "dynamic global %a" else "global %a") Ident.print id
     | Lconst cst -> struct_const ppf cst
-    | Lapply { ap_func; ap_args; ap_info = { ap_inlined; ap_tagged_template } } ->
+    | Lapply { ap_func; ap_args; ap_info = { ap_inlined } } ->
         let lams ppf args =
           List.iter (fun l -> fprintf ppf "@ %a" lam l) args
         in
-        fprintf ppf "@[<2>(apply%s%s@ %a%a)@]"
+        fprintf ppf "@[<2>(apply%s@ %a%a)@]"
           (match ap_inlined with Always_inline -> "%inlned" | _ -> "")
-          (match ap_tagged_template with true -> "%tagged_template" | _ -> "")
           lam ap_func lams ap_args
     | Lfunction { params; body; _ } ->
         let pr_params ppf params =

jscomp/frontend/ast_external_process.ml

@@ -184,6 +184,7 @@ type external_desc = {
   get_name: bundle_source option;
   mk_obj: bool;
   return_wrapper: External_ffi_types.return_wrapper;
+  tagged_template: bool;
 }
 
 let init_st =
@@ -202,6 +203,7 @@ let init_st =
     get_name = None;
     mk_obj = false;
     return_wrapper = Return_unset;
+    tagged_template = false;
   }
 
 let return_wrapper loc (txt : string) : External_ffi_types.return_wrapper =
@@ -291,6 +293,8 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string)
                between unset/set
             *)
             | scopes -> {st with scopes})
+          | "tagged_template" | "taggedTemplate" ->
+            {st with splice = true; tagged_template = true}
           | "bs.splice" | "bs.variadic" | "variadic" -> {st with splice = true}
           | "bs.send" | "send" ->
             {st with val_send = Some (name_from_payload_or_prim ~loc payload)}
@@ -366,6 +370,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
    get_name = None;
    get_index = false;
    return_wrapper = Return_unset;
+   tagged_template = _;
    set_index = false;
    mk_obj = _;
    scopes =
@@ -564,6 +569,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    get_name = None;
    return_wrapper = _;
    mk_obj = _;
+   tagged_template = _;
   } ->
     if arg_type_specs_length = 3 then
       Js_set_index {js_set_index_scopes = scopes}
@@ -588,6 +594,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    set_index = false;
    mk_obj = _;
    return_wrapper = _;
+   tagged_template = _;
   } ->
     if arg_type_specs_length = 2 then
       Js_get_index {js_get_index_scopes = scopes}
@@ -614,6 +621,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    set_index = false;
    return_wrapper = _;
    mk_obj = _;
+   tagged_template = _;
   } -> (
     match (arg_types_ty, new_name, val_name) with
     | [], None, _ -> Js_module_as_var external_module_name
@@ -655,6 +663,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    mk_obj = _;
    (* mk_obj is always false *)
    return_wrapper = _;
+   tagged_template;
   } ->
     let name = prim_name_or_pval_prim.name in
     if arg_type_specs_length = 0 then
@@ -665,7 +674,9 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
          FIXME: splice is not supported here 
       *)
       Js_var {name; external_module_name = None; scopes}
-    else Js_call {splice; name; external_module_name = None; scopes}
+    else
+      Js_call
+        {splice; name; external_module_name = None; scopes; tagged_template}
   | {
    call_name = Some {name; source = _};
    splice;
@@ -681,6 +692,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    get_name = None;
    mk_obj = _;
    return_wrapper = _;
+   tagged_template;
   } ->
     if arg_type_specs_length = 0 then
       (*
@@ -690,7 +702,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
         *)
       Js_var {name; external_module_name; scopes}
       (*FIXME: splice is not supported here *)
-    else Js_call {splice; name; external_module_name; scopes}
+    else Js_call {splice; name; external_module_name; scopes; tagged_template}
   | {call_name = Some _; _} ->
     Bs_syntaxerr.err loc
       (Conflict_ffi_attribute "Attribute found that conflicts with %@val")
@@ -709,6 +721,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    return_wrapper = _;
    splice = false;
    scopes;
+   tagged_template = _;
   } ->
     (*
          if no_arguments -->
@@ -735,6 +748,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    get_name = None;
    mk_obj = _;
    return_wrapper = _;
+   tagged_template;
   } ->
     let name = prim_name_or_pval_prim.name in
     if arg_type_specs_length = 0 then
@@ -744,7 +758,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
          ]}
       *)
       Js_var {name; external_module_name; scopes}
-    else Js_call {splice; name; external_module_name; scopes}
+    else Js_call {splice; name; external_module_name; scopes; tagged_template}
   | {
    val_send = Some {name; source = _};
    splice;
@@ -760,6 +774,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    external_module_name = None;
    mk_obj = _;
    return_wrapper = _;
+   tagged_template = _;
   } -> (
     (* PR #2162 - since when we assemble arguments the first argument in
        [@@send] is ignored
@@ -791,6 +806,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    scopes;
    mk_obj = _;
    return_wrapper = _;
+   tagged_template = _;
   } ->
     Js_new {name; external_module_name; splice; scopes}
   | {new_name = Some _; _} ->
@@ -811,6 +827,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    mk_obj = _;
    return_wrapper = _;
    scopes;
+   tagged_template = _;
   } ->
     if arg_type_specs_length = 2 then
       Js_set {js_set_scopes = scopes; js_set_name = name}
@@ -834,6 +851,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    mk_obj = _;
    return_wrapper = _;
    scopes;
+   tagged_template = _;
   } ->
     if arg_type_specs_length = 1 then
       Js_get {js_get_name = name; js_get_scopes = scopes}

jscomp/frontend/external_ffi_types.ml

@@ -53,6 +53,7 @@ type external_spec =
       external_module_name: external_module_name option;
       splice: bool;
       scopes: string list;
+      tagged_template: bool;
     }
   | Js_send of {name: string; splice: bool; js_send_scopes: string list}
     (* we know it is a js send, but what will happen if you pass an ocaml objct *)
@@ -188,7 +189,9 @@ 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; splice = _; scopes = _}
-  | Js_call {external_module_name; name; splice = _; scopes = _} ->
+  | Js_call
+      {external_module_name; name; splice = _; scopes = _; tagged_template = _}
+    ->
     Ext_option.iter external_module_name (fun external_module_name ->
         upgrade (is_package_relative_path external_module_name.bundle));
     Ext_option.iter external_module_name (fun name ->