translate bs.send.pipe into bs.send internally

Author: bobzhang

jscomp/frontend/ast_attributes.ml

@@ -221,7 +221,37 @@ let process_derive_type (attrs : t) : derive_attr * t =
          st, attr::acc
     ) 
 
-
+let process_send_pipe (attrs : t ) : (Parsetree.core_type * t) option  = 
+  match attrs with 
+  | [] -> None   
+  | _ -> 
+    if not (Ext_list.exists_fst attrs (fun {txt} -> txt = "bs.send.pipe")) then 
+      (* fast path *)
+      None 
+    else 
+      let ty = ref None in  
+      let attrs = 
+        Ext_list.fold_left attrs []
+          (fun acc ({txt ; loc}, payload  as attr)  ->
+             match   txt  with
+             |  "bs.send.pipe" 
+               ->
+               begin match !ty with 
+                 |  None -> 
+                   Location.prerr_warning loc (Warnings.Bs_ffi_warning "This attribute is deprecated, use @send instead.");
+
+                   ty:=Some (Ast_payload.as_core_type loc payload);
+                   (({Asttypes.txt = "bs.send";loc}, Parsetree.PStr []):: acc)
+                 | Some _
+                   ->
+                   Location.raise_errorf ~loc "Duplicated bs.send.pipe"
+               end 
+             | _  ->
+               attr::acc
+          ) in 
+      match !ty with 
+      | None -> assert false
+      | Some ty -> Some (ty, attrs)
 
 (* duplicated @uncurry @string not allowed,
    it is worse in @uncurry since it will introduce

jscomp/frontend/ast_core_type.ml

@@ -167,6 +167,16 @@ let get_uncurry_arity (ty : t ) =
 let get_curry_arity  ty =
   get_uncurry_arity_aux ty 0
 
+(* add hoc for bs.send.pipe *)
+let rec get_curry_labels (ty : t) acc  =
+  match ty.ptyp_desc with 
+  | Ptyp_arrow(label, _, rest)
+    -> get_curry_labels rest (label ::acc)  
+  | _ -> acc 
+
+let get_curry_labels ty = 
+  List.rev (get_curry_labels ty [])
+
 let is_arity_one ty = get_curry_arity ty =  1
 
 

jscomp/frontend/ast_core_type.mli

@@ -57,6 +57,7 @@ val is_user_option : t -> bool
 val get_uncurry_arity : t -> int option
 
 
+val get_curry_labels : t -> Asttypes.arg_label list 
 
 (** fails when Ptyp_poly *)
 val list_of_arrow :

jscomp/frontend/ast_external.ml

@@ -32,32 +32,46 @@ let handleExternalInSig
   let loc = prim.pval_loc in  
   let pval_type = self.typ self prim.pval_type in
   let pval_attributes = self.attributes self prim.pval_attributes in
-  match prim.pval_prim with
-  | [] -> 
-    Location.raise_errorf
-      ~loc
-      "empty primitive string" 
-  | a :: b :: _ ->
-    Location.raise_errorf
-      ~loc
-      "only a single string is allowed in bs external %S %S" a b
-  | [ v ] ->
-    match Ast_external_process.handle_attributes_as_string
-            loc
-            pval_type
-            pval_attributes
-            prim.pval_name.txt            
-            v 
-    with
-    | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->        
-      {sigi with
-       psig_desc =
-         Psig_value
-           {prim with
-            pval_type ;
-            pval_prim = if no_inline_cross_module then [] else pval_prim ;
-            pval_attributes
-           }}
+  match Ast_attributes.process_send_pipe pval_attributes with 
+  | Some (obj , _) -> 
+    (*has bs.send.pipe: best effort *)
+    begin {
+      sigi with 
+      psig_desc = Psig_value {
+          prim with 
+          pval_type = Ast_helper.Typ.arrow ~loc Nolabel obj pval_type ; 
+          pval_prim = []; 
+          pval_attributes = []
+        }
+    } 
+    end   
+  | None  -> 
+    match prim.pval_prim with
+    | [] -> 
+      Location.raise_errorf
+        ~loc
+        "empty primitive string" 
+    | a :: b :: _ ->
+      Location.raise_errorf
+        ~loc
+        "only a single string is allowed in bs external %S %S" a b
+    | [ v ] ->
+      match Ast_external_process.handle_attributes_as_string
+              loc
+              pval_type
+              pval_attributes
+              prim.pval_name.txt            
+              v 
+      with
+      | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->        
+        {sigi with
+         psig_desc =
+           Psig_value
+             {prim with
+              pval_type ;
+              pval_prim = if no_inline_cross_module then [] else pval_prim ;
+              pval_attributes
+             }}
 
 let handleExternalInStru
     (self : Bs_ast_mapper.mapper)
@@ -67,6 +81,13 @@ let handleExternalInStru
   let loc = prim.pval_loc in 
   let pval_type = self.typ self prim.pval_type in
   let pval_attributes = self.attributes self prim.pval_attributes in
+  let send_pipe = ref false in 
+  let pval_type , pval_attributes = 
+    match Ast_attributes.process_send_pipe pval_attributes with 
+    | Some (obj, attrs) -> 
+      send_pipe := true ; 
+      Ast_helper.Typ.arrow ~loc Nolabel obj pval_type, attrs
+    | None  -> pval_type, pval_attributes in 
   match prim.pval_prim with
   | [] 
     -> 
@@ -95,6 +116,44 @@ let handleExternalInStru
               pval_prim;
               pval_attributes
              }} in 
+      if !send_pipe then        
+        let [@warning "-8"] ((_::params) as args) = Ast_core_type.get_curry_labels pval_type in 
+        let arity = List.length args in 
+        let open Ast_helper in 
+        Str.include_ ~loc 
+          (Incl.mk ~loc 
+             (Mod.structure ~loc 
+                [external_result;
+                 Str.value 
+                   ~loc Nonrecursive [
+                   Vb.mk ~loc 
+                     (Pat.var ~loc prim.pval_name)
+
+                     (let body = (Exp.apply ~loc 
+                                    (Exp.ident ~loc {txt = Lident prim.pval_name.txt; loc }) 
+                                    (Ext_list.mapi args (fun i x ->
+                                         match x with 
+                                         | Asttypes.Nolabel -> 
+                                           Asttypes.Nolabel, Exp.ident {txt = Lident ("arg"^string_of_int i); loc}
+                                         | Labelled s 
+                                         | Optional s 
+                                           -> 
+                                           x, Exp.ident {txt = Lident s ; loc}
+                                       ))
+                                 ) in 
+                      snd @@ 
+                      Ext_list.fold_right
+                        params (0, Exp.fun_  Nolabel None (Pat.var ~loc { txt = "arg0"; loc} ) body) (
+                        fun arg (i, obj) -> 
+                          i + 1, Exp.fun_ arg None 
+                            (Pat.var ~loc {txt = (match arg with | Labelled s | Optional s -> s 
+                                                                 | Nolabel -> "arg" ^ string_of_int (arity - i - 1)); loc}) obj
+                      )
+                     )
+                 ]
+                ])
+          )
+      else 
       if not no_inline_cross_module then   
         external_result
       else