Merge pull request #416 from bloomberg/clean_up_uncurry_obj

done with object type protection

Author: bobzhang

docs/Playground.md

@@ -0,0 +1,11 @@
+
+
+There are two Playgrounds, one for
+[vanilla OCaml](https:////bloomberg.github.io/bucklescript/js-demo),
+the other for
+[Facebook Reason](https:////bloomberg.github.io/bucklescript/reason-demo)
+
+Note that the playgrounds are only for demos, it might not be the latest,
+you should always use the command line as your production tools.
+
+

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,11 +19,11 @@ 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 [BuckleScript](https://github.com/bloomberg/bucklescript)?
 
 BuckleScript is mainly designed to solve the problems of large scale JavaScript programming:
 
-1. **Lack of type-safety:** OCaml offers an industrial-strength state-of-the-art type system and provides type inference (i.e. No verbose type annotation required), which proves [invaluable](http://programmers.stackexchange.com/questions/215482/what-are-the-safety-benefits-of-a-type-system) in managing large projects.
+1. **Lack of type-safety:** [OCaml]((https://ocaml.org/) offers an industrial-strength state-of-the-art type system and provides type inference (i.e. No verbose type annotation required), which proves [invaluable](http://programmers.stackexchange.com/questions/215482/what-are-the-safety-benefits-of-a-type-system) in managing large projects.
 
 2. **Dead code:** A large amount of web-development relies on inclusion of code dependencies by copying or referencing CDNs (the very thing that makes JavaScript highly accessible), but this also introduces a lot of [dead code](https://en.wikipedia.org/wiki/Dead_code). This impacts performance adversely when the JavaScript VM has to interpret code that will never be invoked. BuckleScript provides powerful dead-code elimination at all levels. Function and module level elimination is facilitated by the sophistication of the type-system of OCaml, and at the global level BuckleScript generates code ready for dead-code elimination done by bundling tools such as the [Google closure-compiler](https://developers.google.com/closure/compiler/).
 

docs/SUMMARY.md

@@ -1,6 +1,7 @@
 * [Home](./README.md)
 
-* [Playground](https://bloomberg.github.io/bucklescript/js-demo)
+* Playground
+  * [OCaml & Reason Playgrounds](./Playground.md)
 
 * Get Started
   * [Installation](./Installation.md)
@@ -29,7 +30,7 @@
   * [Unsupported IO primitives](./Unsupported-IO-primitives.md)
 
 * Contributions
-  * [Github Link](https://github.com/bloomberg/bucklescript)
+
   * [Dev mode How to](./Dev-mode-How-to.md)
   * [Help move runtime functions from OCaml to Javascript](./Help-move-runtime-functions-from-OCaml-to-Javascript.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]