remove bs class type and auto uncurry for less magic

Author: Hongbo Zhang

jscomp/syntax/ppx_entry.ml

@@ -64,16 +64,14 @@ let record_as_js_object = ref false (* otherwise has an attribute *)
 
 let obj_type_as_js_obj_type = ref false
 let uncurry_type = ref false 
-let obj_type_auto_uncurry =  ref false
+
 let no_export = ref false 
-let bs_class_type = ref false 
+
 
 let reset () = 
   record_as_js_object := false ;
   obj_type_as_js_obj_type := false ;
   uncurry_type := false ;
-  obj_type_auto_uncurry := false ;
-  bs_class_type := false;
   no_export  :=  false
 
 
@@ -201,11 +199,7 @@ let handle_typ
     ptyp_loc = loc 
     } -> 
 
-    let check_auto_uncurry core_type = 
-      if  !obj_type_auto_uncurry then
-        Ext_ref.non_exn_protect uncurry_type true 
-          (fun _ -> self.typ self core_type  )          
-      else self.typ self core_type in 
+    let check_auto_uncurry core_type = self.typ self core_type in 
     let methods, ptyp_attributes  =
       begin match Ext_list.exclude_with_fact
                     (function 
@@ -475,29 +469,39 @@ let rec unsafe_mapper : Ast_mapper.mapper =
       );
     typ = (fun self typ -> handle_typ Ast_mapper.default_mapper self typ);
     class_type = 
-      (fun self ({pcty_attributes} as ctd) -> 
+      (fun self ({pcty_attributes; pcty_loc} as ctd) -> 
          match Ast_attributes.process_bs pcty_attributes with 
          | `Nothing,  _ -> 
            Ast_mapper.default_mapper.class_type
              self ctd 
-         | `Has, pcty_attributes -> 
-           Ext_ref.non_exn_protect bs_class_type true begin fun _ -> 
-             Ast_mapper.default_mapper.class_type
-               self {ctd with pcty_attributes}
-           end
+         | `Has, pcty_attributes ->
+           begin match ctd.pcty_desc with
+             | Pcty_signature ({pcsig_self; pcsig_fields })
+               ->
+               let pcsig_self = self.typ self pcsig_self in 
+               {ctd with
+                pcty_desc = Pcty_signature {
+                    pcsig_self ;
+                    pcsig_fields = List.fold_right (fun  f  acc ->
+                        handle_class_type_field  acc self f 
+                      )  pcsig_fields []
+                  };
+                pcty_attributes                    
+               }                    
+
+             | Pcty_constr _
+             | Pcty_extension _ 
+             | Pcty_arrow _ ->
+               Location.raise_errorf ~loc:pcty_loc "invalid or unused attribute `bs`"
+               (* {[class x : int -> object 
+                    end [@bs]
+                  ]}
+                  Actually this is not going to happpen as below is an invalid syntax
+                  {[class type x = int -> object
+                    end[@bs]]}
+               *)
+           end             
       );
-    class_signature = begin fun self ({pcsig_self; pcsig_fields } as csg) -> 
-      if !bs_class_type then 
-        let pcsig_self = self.typ self pcsig_self in 
-        {
-          pcsig_self ;
-          pcsig_fields = List.fold_right (fun  f  acc ->
-              handle_class_type_field  acc self f 
-            )  pcsig_fields []
-        }
-      else 
-        Ast_mapper.default_mapper.class_signature self csg 
-    end;
     signature_item =  begin fun (self : Ast_mapper.mapper) (sigi : Parsetree.signature_item) -> 
       match sigi.psig_desc with 
       | Psig_type [{ptype_attributes} as tdcl] -> 
@@ -607,18 +611,7 @@ let rec unsafe_mapper : Ast_mapper.mapper =
 (** global configurations below *)
 let common_actions_table : 
   (string *  (Parsetree.expression option -> unit)) list = 
-  [ "obj_type_auto_uncurry", 
-    (fun e -> 
-       obj_type_auto_uncurry := 
-         (match e with Some e -> Ast_payload.assert_bool_lit e
-         | None -> true)
-    ); 
-    "bs_class_type", 
-    (fun e -> 
-       bs_class_type := 
-         (match e with Some e -> Ast_payload.assert_bool_lit e 
-         | None -> true)
-    )
+  [ 
   ]
 
 

jscomp/test/.depend

@@ -405,6 +405,8 @@ mt.cmj : ../stdlib/list.cmi ../others/bs_node.cmi ../stdlib/array.cmi mt.cmi
 mt.cmx : ../stdlib/list.cmx ../others/bs_node.cmi ../stdlib/array.cmx mt.cmi
 mt_global.cmj : mt.cmi mt_global.cmi
 mt_global.cmx : mt.cmx mt_global.cmi
+mutable_obj_test.cmj : ../runtime/js.cmj
+mutable_obj_test.cmx : ../runtime/js.cmx
 mutual_non_recursive_type.cmj :
 mutual_non_recursive_type.cmx :
 nested_include.cmj :
@@ -1175,6 +1177,8 @@ mt.cmo : ../stdlib/list.cmi ../others/bs_node.cmi ../stdlib/array.cmi mt.cmi
 mt.cmj : ../stdlib/list.cmj ../others/bs_node.cmi ../stdlib/array.cmj mt.cmi
 mt_global.cmo : mt.cmi mt_global.cmi
 mt_global.cmj : mt.cmj mt_global.cmi
+mutable_obj_test.cmo : ../runtime/js.cmo
+mutable_obj_test.cmj : ../runtime/js.cmj
 mutual_non_recursive_type.cmo :
 mutual_non_recursive_type.cmj :
 nested_include.cmo :

jscomp/test/Makefile

@@ -60,7 +60,7 @@ OTHERS := literals a test_ari test_export2 test_internalOO test_obj_simple_ffi t
 	bs_rest_test infer_type_test fs_test module_as_function\
 	test_case_set test_mutliple string_bound_get_test inline_string_test\
 	ppx_this_obj_test unsafe_obj_external gpr_627_test jsoo_485_test jsoo_400_test	\
-	test_require more_uncurry earger_curry_test poly_type bench
+	test_require more_uncurry earger_curry_test poly_type bench mutable_obj_test
 
 
 

jscomp/test/class_setter_getter.ml

@@ -1,27 +1,27 @@
 
-[@@@bs.config{bs_class_type}]
+
 
 class type _y = object 
   method height : int [@@bs.set {no_get}]
-end
+end [@bs]
 type y = _y Js.t 
 class type _y0 = object 
   method height : int [@@bs.set] [@@bs.get {null}]
-end
+end [@bs]
 type y0 = _y0 Js.t 
 
 class type _y1 = object 
   method height : int [@@bs.set] [@@bs.get {undefined}]
-end
+end[@bs]
 type y1 = _y1 Js.t 
 
 class type _y2 = object 
   method height : int [@@bs.set] [@@bs.get {undefined; null}]
-end
+end [@bs]
 type y2 = _y2 Js.t 
 
 class type _y3 = object 
   method height : int  [@@bs.get {undefined ; null}]
-end
+end[@bs]
 type y3 = _y3 Js.t
 

jscomp/test/class_type_ffi_test.ml

@@ -1,14 +1,14 @@
-[@@@bs.config{bs_class_type  }]
+
 class type ['k,'v] arrayLike = 
   object 
     method case : 'k -> 'v Js.Null.t 
     method caseSet : 'k * 'v -> unit 
     method case_unsafe : 'k -> 'v 
     method length : int 
-  end
+  end[@bs]
 
 class type floatArray = [int, float] arrayLike
-
+(** here we can see [@bs] is really attached to `object end` instead of `class type` *)
 class type intArray = [int, int] arrayLike
 
 

jscomp/test/config1_test.ml

@@ -1,6 +1,6 @@
 
 ;;[@@@bs.config{
-  obj_type_auto_uncurry ;
+  
   no_export ;
 }]
 ;;

jscomp/test/config2_test.ml

@@ -1,27 +1,23 @@
-[@@@bs.config{
-  obj_type_auto_uncurry ;
-  bs_class_type 
-  (* no_export = true; *)
-}]
+
 
 
 
 class type v = object 
   method hey : int -> int -> int 
-end 
+end [@bs]
 
 class type v2 = object
   method hey : int ->  int -> int 
-end 
+end [@bs]
 
 type vv = 
   [%bs.obj: < 
-    hey : int -> int -> int 
-  >  [@bs] ]
+    hey : int -> int -> int [@bs]
+  >   ]
 
 type vv2 = 
   [%bs.obj: < 
-    hey : int ->  int -> int 
+    hey : int ->  int -> int [@bs]
   > ] 
 
 

jscomp/test/config2_test.mli

@@ -1,24 +1,21 @@
-[@@@bs.config {obj_type_auto_uncurry  ; (* no_export = true *) 
-bs_class_type 
-} ]
 
 
 class type v = object
   method hey : int -> int -> int 
-end 
+end [@bs]
 
 class type v2 = object
   method hey : int -> int -> int 
-end 
+end [@bs]
 
 type vv = 
   [%bs.obj: < 
-    hey : int -> int -> int 
-  >  [@bs]]
+    hey : int -> int -> int [@bs]
+  >  ]
 
 type vv2 = 
   [%bs.obj: < 
-    hey : int -> int -> int 
+    hey : int -> int -> int [@bs]
   > ]
 
 

jscomp/test/demo_binding.ml

@@ -1,53 +1,52 @@
-[@@@bs.config{bs_class_type }]
 
 class type titlex = 
   object 
     method title : string [@@bs.set] [@@bs.get {null ; undefined}]
-  end
+  end[@bs]
 
 class type widget = 
   object 
       method on : string ->  (event -> unit [@bs]) -> unit 
-  end
+  end[@bs]
 and  event = 
   object 
     method source : widget
     method target : widget
-  end
+  end[@bs]
 
 
 class type title = 
   object 
     method title : string [@@bs.set]
-  end
+  end[@bs]
 
 class type text = 
   object
     method text : string [@@bs.set]
-  end
+  end[@bs]
 
 class type measure =
     object
       method minHeight : int [@@bs.set]
       method minWidth : int [@@bs.set]
       method maxHeight : int  [@@bs.set]
       method maxWidth : int [@@bs.set]
-    end
+    end[@bs]
 
 class type layout = 
     object 
       method orientation : string [@@bs.set]
-    end
+    end[@bs]
 
 class type applicationContext = 
   object 
     method exit : int -> unit 
-  end
+  end[@bs]
 class type contentable = 
   object
     method content : #widget Js.t [@@bs.set]
     method contentWidth : int  [@@bs.set]
-  end
+  end[@bs]
 
 class type hostedWindow =
   object
@@ -58,13 +57,13 @@ class type hostedWindow =
     method hide : unit -> unit 
     method focus : unit -> unit 
     method appContext : applicationContext [@@bs.set]
-  end
+  end[@bs]
 
 class type hostedContent =
   object 
     inherit widget
     inherit contentable
-  end
+  end[@bs]
 
 
 class type stackPanel = 
@@ -75,7 +74,7 @@ class type stackPanel =
 
     method addChild : #widget Js.t -> unit 
 
-  end
+  end[@bs]
 
 class type grid  = 
   object
@@ -86,22 +85,22 @@ class type grid  =
       [%bs.obj: <label : <text : string; .. >   ; ..> ]   array [@@bs.set]
     method dataSource :
       [%bs.obj: <label : <text : string; .. >   ; ..>  ]  array array [@@bs.set]
-  end
+  end[@bs]
 
 
 class type button = 
   object
     inherit widget
     inherit text
     inherit measure
-  end
+  end[@bs]
 
 class type textArea = 
   object
     inherit widget
     inherit measure
     inherit text 
-  end
+  end[@bs]
 
 
 external set_interval : (unit -> unit [@bs]) -> float -> unit  =  "setInterval"