[feature] provide [%uncurry: < x : int ; y : int > Js.t ] syntactic sugar

jscomp/compiler.mllib

@@ -15,6 +15,7 @@ ext_ident
 ext_pp
 ext_option
 ext_list
+ext_ref
 ext_string
 ext_char
 ext_format

jscomp/ext_list.ml

@@ -38,6 +38,36 @@ let rec filter_map (f: 'a -> 'b option) xs =
       | Some z -> z :: filter_map f ys
       end
 
+let excludes p l =
+  let excluded = ref false in 
+  let rec aux accu = function
+  | [] -> List.rev accu
+  | x :: l -> 
+    if p x then 
+      begin 
+        excluded := true ;
+        aux accu l
+      end
+    else aux (x :: accu) l in
+  let v = aux [] l in 
+  if !excluded then true, v else false,l
+
+let exclude_with_fact p l =
+  let excluded = ref None in 
+  let rec aux accu = function
+  | [] -> List.rev accu
+  | x :: l -> 
+    if p x then 
+      begin 
+        excluded := Some x ;
+        aux accu l
+      end
+    else aux (x :: accu) l in
+  let v = aux [] l in 
+  !excluded , if !excluded <> None then v else l 
+
+
+
 let rec same_length xs ys = 
   match xs, ys with 
   | [], [] -> true

jscomp/ext_list.mli

@@ -35,6 +35,8 @@
 
 val filter_map : ('a -> 'b option) -> 'a list -> 'b list 
 
+val excludes : ('a -> bool) -> 'a list -> bool * 'a list
+val exclude_with_fact : ('a -> bool) -> 'a list -> 'a option * 'a list
 val same_length : 'a list -> 'b list -> bool
 
 val init : int -> (int -> 'a) -> 'a list

jscomp/ext_ref.ml

@@ -0,0 +1,34 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ * 
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ * 
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+let protect r v body =
+  let old = !r in
+  try
+    r := v;
+    let res = body() in
+    r := old;
+    res
+  with x ->
+    r := old;
+    raise x

jscomp/ext_ref.mli

@@ -0,0 +1,25 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ * 
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ * 
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b

jscomp/ppx_entry.ml

@@ -118,17 +118,12 @@ let handle_raw ?ty loc e attrs  =
     | None -> predef_any_type))
 
 
-(** TODO: Should remove all [uncurry] attributes *)
+
 let find_uncurry_attrs_and_remove (attrs : Parsetree.attributes ) = 
-  let rec aux (attrs : Parsetree.attributes) acc = 
-    match attrs with 
-    | [({txt = "uncurry"}, _) as v ]  -> Some (List.rev acc, v)
-    | ({txt = "uncurry"}, _) as v :: rest -> 
-      Some ((List.rev acc @ rest)  , v)
-    | non_uncurry :: rest -> aux rest  (non_uncurry :: acc) 
-    | [] -> None 
-  in 
-  aux attrs []
+  Ext_list.exclude_with_fact (function 
+    | ({Location.txt  = "uncurry"}, _) -> true 
+    | _ -> false ) attrs 
+
 
 let uncurry_attr loc  : Parsetree.attribute = 
   {txt = "uncurry"; loc}, PStr []
@@ -161,27 +156,48 @@ let uncurry_fn_type loc ty ptyp_attributes
             ptyp_attributes = []
   }
 
+let uncurry = ref false 
+
+(*
+  Attributes are very hard to attribute
+  (since ptyp_attributes could happen in so many places), 
+  and write ppx extensions correctly, 
+  we can only use it locally
+*)
+
 let handle_typ 
     (super : Ast_mapper.mapper) 
     (self : Ast_mapper.mapper)
     (ty : Parsetree.core_type) = 
   match ty with
+  | {ptyp_desc = 
+       Ptyp_extension({txt = "uncurry"}, 
+                      PTyp ty )}
+    -> 
+    Ext_ref.protect uncurry true begin fun () -> 
+      self.typ self  ty 
+    end
   | {ptyp_attributes ;
      ptyp_desc = Ptyp_arrow ("", args, body);
      ptyp_loc = loc
-    } ->
+   } ->
     begin match  find_uncurry_attrs_and_remove ptyp_attributes with 
-      | Some (ptyp_attributes, _) ->
+    | Some _, ptyp_attributes ->
         let args = self.typ self args in
         let body = self.typ self body in
         uncurry_fn_type loc ty ptyp_attributes args body 
-      | None -> super.typ self ty
+    | None, _ -> 
+        let args = self.typ self args in
+        let body = self.typ self body in
+        if !uncurry then 
+          uncurry_fn_type loc ty ptyp_attributes args body 
+        else {ty with ptyp_desc = Ptyp_arrow("", args, body)}
     end
   | {ptyp_desc =  Ptyp_object ( methods, closed_flag) } -> 
     let methods = List.map (fun (label, ptyp_attrs, core_type ) -> 
         match find_uncurry_attrs_and_remove ptyp_attrs with 
-        | None -> label, ptyp_attrs , self.typ self core_type
-        | Some (ptyp_attrs, v) -> 
+        | None, _ -> label, ptyp_attrs , self.typ self core_type
+        | Some v, ptyp_attrs -> 
           label , ptyp_attrs, self.typ self 
             { core_type with ptyp_attributes = v :: core_type.ptyp_attributes}
       ) methods in           

jscomp/test/.depend

@@ -224,8 +224,8 @@ hashtbl_test.cmj : mt.cmi ../stdlib/moreLabels.cmi ../stdlib/list.cmi \
     ../stdlib/hashtbl.cmi ../stdlib/array.cmi
 hashtbl_test.cmx : mt.cmx ../stdlib/moreLabels.cmx ../stdlib/list.cmx \
     ../stdlib/hashtbl.cmx ../stdlib/array.cmx
-http_types.cmj : ../runtime/js.cmj
-http_types.cmx : ../runtime/js.cmx
+http_types.cmj :
+http_types.cmx :
 ignore_test.cmj : mt.cmi ../runtime/js.cmj
 ignore_test.cmx : mt.cmx ../runtime/js.cmx
 inline_edge_cases.cmj : inline_edge_cases.cmi
@@ -870,8 +870,8 @@ hashtbl_test.cmo : mt.cmi ../stdlib/moreLabels.cmi ../stdlib/list.cmi \
     ../stdlib/hashtbl.cmi ../stdlib/array.cmi
 hashtbl_test.cmj : mt.cmj ../stdlib/moreLabels.cmj ../stdlib/list.cmj \
     ../stdlib/hashtbl.cmj ../stdlib/array.cmj
-http_types.cmo : ../runtime/js.cmo
-http_types.cmj : ../runtime/js.cmj
+http_types.cmo :
+http_types.cmj :
 ignore_test.cmo : mt.cmi ../runtime/js.cmo
 ignore_test.cmj : mt.cmj ../runtime/js.cmj
 inline_edge_cases.cmo : inline_edge_cases.cmi

jscomp/test/http_types.ml

@@ -13,21 +13,22 @@
 
 
 type req 
-type resp = <
-   statusCode__set : int -> unit [@uncurry] ;
-   setHeader : string * string -> unit [@uncurry];
-   end__ : string ->  unit [@uncurry]
->
 
-type server = <
-   listen : int * string *  (unit -> unit  [@uncurry]) -> unit [@uncurry]
->
+type resp = [%uncurry: <
+   statusCode__set : int -> unit  ;
+   setHeader : string * string -> unit ;
+   end__ : string ->  unit 
+> Js.t ]
 
+type server = [%uncurry: <
+   listen : int * string *  (unit -> unit) -> unit 
+> Js.t]
 
 
-type http = <
-   createServer : (req Js.t * resp Js.t -> unit [@uncurry]) ->  server Js.t [@uncurry]
->
 
+type http = [%uncurry:<
+   createServer : (req  * resp  -> unit ) ->  server
+> Js.t ]
 
-external http : http Js.t = "http"  [@@bs.val_of_module ]
+
+external http : http  = "http"  [@@bs.val_of_module ]

jscomp/test/test_index.ml

@@ -26,3 +26,23 @@ let ff (x : int case  Js.t)
 let h (x : (< case : (int ->  (int -> 'a [@uncurry]) [@uncurry]); .. > as 'b) Js.t) = 
   let a = x##case 3 in 
   a #@ 2   
+
+
+type x_obj = [%uncurry: < 
+       case : int ->  int ; 
+       case__set : int * int -> unit ;
+>  Js.t ]
+
+let f_ext 
+    (x : x_obj)
+ = 
+  x ## case__set (3, 2) ;
+  x ## case 3 
+
+type 'a h_obj = [%uncurry: < 
+ case : int ->  (int -> 'a)
+> Js.t ]
+
+let h_ext  (x : 'a h_obj) = 
+  let  a = x ##case 3 in 
+  a #@ 2