done with object type protection

Author: Hongbo Zhang

docs/README.md

@@ -3,8 +3,6 @@
 
 * [FAQ](./FAQ.md)
 
-* [About OCaml](https://ocaml.org/)
-
 * [Compiler options](./Compiler-options.md)
 
 * [How to adapt your build system](./How-to-adapt-your-build-system.md)
@@ -21,7 +19,7 @@ everywhere: users don't need to install binaries or use package managers to acce
 Another important factor is that the JavaScript VM is quite fast and keeps getting faster. 
 The JavaScript platform is therefore increasingly capable of supporting large applications.
 
-# Why OCaml?
+# Why [OCaml](https://ocaml.org/)?
 
 BuckleScript is mainly designed to solve the problems of large scale JavaScript programming:
 

docs/SUMMARY.md

@@ -1,6 +1,8 @@
 * [Home](./README.md)
 
-* [Playground](https://bloomberg.github.io/bucklescript/js-demo)
+* Playground
+  * [OCaml Playground](https://bloomberg.github.io/bucklescript/js-demo)
+  * [Reason Playground](https://bloomberg.github.io/bucklescript/reason-demo)
 
 * Get Started
   * [Installation](./Installation.md)

jscomp/ext_list.ml

@@ -67,6 +67,28 @@ let exclude_with_fact p l =
   !excluded , if !excluded <> None then v else l 
 
 
+(** Make sure [p2 x] and [p1 x] will not hold at the same time *)
+let exclude_with_fact2 p1 p2 l =
+  let excluded1 = ref None in 
+  let excluded2 = ref None in 
+  let rec aux accu = function
+  | [] -> List.rev accu
+  | x :: l -> 
+    if p1 x then 
+      begin 
+        excluded1 := Some x ;
+        aux accu l
+      end
+    else if p2 x then 
+      begin 
+        excluded2 := Some x ; 
+        aux accu l 
+      end
+    else aux (x :: accu) l in
+  let v = aux [] l in 
+  !excluded1, !excluded2 , if !excluded1 <> None && !excluded2 <> None then v else l 
+
+
 
 let rec same_length xs ys = 
   match xs, ys with 

jscomp/ext_list.mli

@@ -37,6 +37,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 exclude_with_fact2 : 
+  ('a -> bool) -> ('a -> bool) -> 'a list -> 'a option * 'a option * 'a list
 val same_length : 'a list -> 'b list -> bool
 
 val init : int -> (int -> 'a) -> 'a list

jscomp/ext_ref.ml

@@ -32,3 +32,19 @@ let protect r v body =
   with x ->
     r := old;
     raise x
+
+
+let protect2 r1 r2 v1 v2 body =
+  let old1 = !r1 in
+  let old2 = !r2 in  
+  try
+    r1 := v1;
+    r2 := v2;
+    let res = body() in
+    r1 := old1;
+    r2 := old2;
+    res
+  with x ->
+    r1 := old1;
+    r2 := old2;
+    raise x

jscomp/ext_ref.mli

@@ -23,3 +23,5 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
+
+val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c

jscomp/ppx_entry.ml

@@ -312,7 +312,7 @@ let uncurry_fn_type loc ty ptyp_attributes
             ptyp_attributes = []
   }
 
-let uncurry = ref false 
+let uncurry_type = ref false 
 
 (*
   Attributes are very hard to attribute
@@ -326,13 +326,6 @@ let handle_typ
     (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
@@ -345,7 +338,7 @@ let handle_typ
     | None, _ -> 
         let args = self.typ self args in
         let body = self.typ self body in
-        if !uncurry then 
+        if !uncurry_type then 
           uncurry_fn_type loc ty ptyp_attributes args body 
         else {ty with ptyp_desc = Ptyp_arrow("", args, body)}
     end
@@ -354,29 +347,15 @@ let handle_typ
     ptyp_attributes ;
     ptyp_loc = loc 
     } -> 
-    begin match Ext_list.exclude_with_fact (function 
-      | {Location.txt = "bs.obj" ; _}, _  -> true 
-      | _  -> false ) ptyp_attributes with 
-    | Some _, ptyp_attributes -> 
-      let methods = 
-        Ext_ref.protect obj_type_as_js_obj_type true begin fun _ -> 
-          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 v, ptyp_attrs -> 
-                label , ptyp_attrs, self.typ self 
-                  { core_type with ptyp_attributes = v :: core_type.ptyp_attributes}
-            ) methods 
-        end
-      in           
-
-      {ptyp_desc = 
-         Ptyp_constr ({ txt = js_obj_type_id () ; loc},
-                      [{ ty with ptyp_desc = Ptyp_object(methods, closed_flag);
-                                 ptyp_attributes }]);
-       ptyp_attributes = [];
-       ptyp_loc = loc }
-    |  None, _  ->
+    begin match Ext_list.exclude_with_fact2 
+                  (function 
+                    | {Location.txt = "bs.obj" ; _}, _  -> true 
+                    | _  -> false ) 
+                  (function 
+                    | {Location.txt = "uncurry"; _}, _ -> true
+                    | _ -> false)
+                  ptyp_attributes with 
+    |  None, None, _  ->
       let methods = 
         List.map (fun (label, ptyp_attrs, core_type ) -> 
             match find_uncurry_attrs_and_remove ptyp_attrs with 
@@ -395,7 +374,33 @@ let handle_typ
          ptyp_loc = loc }
       else 
         {ty with ptyp_desc = Ptyp_object (methods, closed_flag)}
-
+    | fact1 , fact2,  ptyp_attributes -> 
+      let obj_type_as_js_obj_type_cxt =  fact1 <> None || !obj_type_as_js_obj_type in
+      let uncurry_type_cxt  = fact2 <> None || !uncurry_type in 
+      let methods = 
+        Ext_ref.protect2
+          obj_type_as_js_obj_type
+          uncurry_type 
+          obj_type_as_js_obj_type_cxt 
+          uncurry_type_cxt begin fun _ -> 
+          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 v, ptyp_attrs -> 
+                label , ptyp_attrs, self.typ self 
+                  { core_type with ptyp_attributes = v :: core_type.ptyp_attributes}
+            ) methods 
+        end
+      in           
+      let inner_type = { ty with ptyp_desc = Ptyp_object(methods, closed_flag);
+                                 ptyp_attributes } in
+      if obj_type_as_js_obj_type_cxt then       
+        {ptyp_desc = 
+           Ptyp_constr ({ txt = js_obj_type_id () ; loc},
+                        [inner_type]);
+         ptyp_attributes = [];
+         ptyp_loc = loc }
+      else inner_type
     end
   | _ -> super.typ self ty
 
@@ -410,7 +415,7 @@ let handle_ctyp
    } ->
     begin match  find_uncurry_attrs_and_remove pcty_attributes with 
     | Some _, pcty_attributes' ->
-      Ext_ref.protect uncurry true begin fun () -> 
+      Ext_ref.protect uncurry_type true begin fun () -> 
         self.class_type self  {ty with pcty_attributes = pcty_attributes'} 
       end
     | None, _ -> super.class_type self ty

jscomp/test/attr_test.ml

@@ -4,7 +4,13 @@ let u = fun [@uncurry] (x,y) -> x + y
 let h = u (1,2) [@uncurry]
 
 type u = < v : int ; y : int > [@uncurry]
+type ('a,'b) xx = 
+  (< case : (int ->  (int -> 'a [@uncurry]) [@uncurry]); .. >   as 'b) 
+type ('a,'b) xx_uncurry = 
+  (< case : int ->  (int -> 'a ); .. >  [@uncurry]) as 'b
 
+type yy_uncurry = < x : int > [@uncurry]
+type yy = < x : int > 
 type number = float
 
 class type date = 

jscomp/test/http_types.ml

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

jscomp/test/test_index.ml

@@ -4,16 +4,16 @@
 
 
 
-let f (x : (< case : int ->  'a [@uncurry]; 
-            case__set : int * int -> unit [@uncurry];
-            .. > as 'b) Js.t)
+let f (x : < case : int ->  'a ; 
+            case__set : int * int -> unit ;
+            .. > [@uncurry] [@bs.obj])
  = 
   x ## case__set (3, 2) ;
   x ## case 3 
 
-class type ['a] case = object 
-  method case : int -> 'a [@uncurry]
-  method case__set : int * 'a -> unit [@uncurry]
+class type ['a] case = object [@uncurry]
+  method case : int -> 'a 
+  method case__set : int * 'a -> unit 
 end
 
 let ff (x : int case  Js.t)
@@ -23,26 +23,29 @@ let ff (x : int case  Js.t)
 
 
 
-let h (x : (< case : (int ->  (int -> 'a [@uncurry]) [@uncurry]); .. > as 'b) Js.t) = 
+let h (x : 
+         < case : (int ->  (int -> 'a ) ); .. >  [@uncurry] [@bs.obj]) = 
   let a = x##case 3 in 
-  a #@ 2   
+  a 2 [@uncurry]   
 
 
-type x_obj = [%uncurry: < 
-       case : int ->  int ; 
-       case__set : int * int -> unit ;
->  Js.t ]
+type x_obj =  
+  < 
+    case : int ->  int ; 
+    case__set : int * int -> unit ;
+  >  [@uncurry] [@bs.obj]
 
 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 ]
+type 'a h_obj = 
+  < 
+    case : int ->  (int -> 'a)
+  > [@uncurry] [@bs.obj]
 
 let h_ext  (x : 'a h_obj) = 
   let  a = x ##case 3 in 
-  a #@ 2 
+  a 2 [@uncurry]