fix a bug in bs.set

rescript-lang · Jul 6, 2016 · 1eeb5c8 · 1eeb5c8
1 parent 6c17881
commit 1eeb5c8
Show file tree

Hide file tree

Showing 4 changed files with 94 additions and 57 deletions.
diff --git a/jscomp/syntax/ppx_entry.ml b/jscomp/syntax/ppx_entry.ml
@@ -106,66 +106,72 @@ let handle_class_type_field  acc =
      | Pctf_method 
          (name, private_flag, virtual_flag, ty) 
        -> 
-       let (pctf_attributes, st) = 
+       let pctf_attributes, st = 
          Ast_util.process_method_attributes_rev ctf.pctf_attributes 
        in 
-       begin match ty.ptyp_desc with 
-         | Ptyp_arrow ("", args, body) 
-           -> 
-           { ctf with 
-             pctf_desc = 
-               Pctf_method (name, 
-                            private_flag,
-                            virtual_flag, 
-                            Ast_util.destruct_arrow_as_meth_type 
-                              ty.ptyp_loc args body self );
-             pctf_attributes 
-           } :: acc 
-         | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow ("", args, body); ptyp_loc})
-           -> 
-           {ctf with 
-            pctf_desc = 
-              Pctf_method 
-                (name,
-                 private_flag, 
-                 virtual_flag, 
-                 {ty with ptyp_desc = 
-                            Ptyp_poly(strs,             
-                                      Ast_util.destruct_arrow_as_meth_type
-                                        ptyp_loc args body self  )});
-            pctf_attributes
-           }  :: acc 
-         | _ -> 
-           match st with 
-           | {set = Some _ } 
-             -> 
+       begin match st with 
+         | {get = None; set = None} -> 
+           begin match ty.ptyp_desc with 
+             | Ptyp_arrow ("", args, body) 
+               -> 
+               { ctf with 
+                 pctf_desc = 
+                   Pctf_method (name, 
+                                private_flag,
+                                virtual_flag, 
+                                Ast_util.destruct_arrow_as_meth_type 
+                                  ty.ptyp_loc args body self );
+                 pctf_attributes 
+               } :: acc 
+             | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow ("", args, body); ptyp_loc})
+               -> 
                {ctf with 
-                pctf_desc =
-                  Pctf_method (name ^ Literals.setter_suffix, 
-                               private_flag,
-                               virtual_flag,
-                               Ast_util.destruct_arrow_as_meth_type 
-                                 loc 
-                                 ty 
-                                 (Ast_literal.type_unit ~loc ())
-                                 self 
-                              );
-                pctf_attributes}
-             :: {ctf with 
-                pctf_desc =  
-                  Pctf_method (name , 
-                               private_flag, 
-                               virtual_flag, 
-                               self.typ self ty
-                              );
+                pctf_desc = 
+                  Pctf_method 
+                    (name,
+                     private_flag, 
+                     virtual_flag, 
+                     {ty with ptyp_desc = 
+                                Ptyp_poly(strs,             
+                                          Ast_util.destruct_arrow_as_meth_type
+                                            ptyp_loc args body self  )});
+                pctf_attributes
+               }  :: acc 
+             | _ -> 
+               {ctf with 
+                pctf_desc =  Pctf_method (name , private_flag, virtual_flag, self.typ self ty);
                 pctf_attributes}
-             :: acc 
-           (*TODO: test on poly type *)
-           | _ -> 
-             {ctf with 
-              pctf_desc =  Pctf_method (name , private_flag, virtual_flag, self.typ self ty);
-              pctf_attributes}
-             :: acc 
+               :: acc 
+           end
+         | {set = Some _ } 
+           -> 
+           {ctf with 
+            pctf_desc =
+              Pctf_method (name ^ Literals.setter_suffix, 
+                           private_flag,
+                           virtual_flag,
+                           Ast_util.destruct_arrow_as_meth_type 
+                             loc 
+                             ty 
+                             (Ast_literal.type_unit ~loc ())
+                             self 
+                          );
+            pctf_attributes}
+           :: {ctf with 
+               pctf_desc =  
+                 Pctf_method (name , 
+                              private_flag, 
+                              virtual_flag, 
+                              self.typ self ty
+                             );
+               pctf_attributes}
+           :: acc 
+         (*TODO: test on poly type *)
+         | {set = None ; } -> 
+           {ctf with 
+            pctf_desc =  Pctf_method (name , private_flag, virtual_flag, self.typ self ty);
+            pctf_attributes}
+           :: acc 
        end
      | Pctf_inherit _ 
      | Pctf_val _ 

diff --git a/jscomp/test/test_bs_this.ml b/jscomp/test/test_bs_this.ml
@@ -1,3 +1,5 @@
+[@@@bs.config{bs_class_type}]
+
 let uux_this :[%bs.obj: < length : int > ] -> int -> int -> int [@bs.this] 
   =
   fun[@bs.this] o x y -> o##length + x + y
@@ -22,3 +24,18 @@ let js_obj : 'self =
 
       }
   ]
+class type _x = object 
+  method onload : (_x Js.t -> unit [@bs.this]) [@@bs.set]
+  method addEventListener : string -> (_x Js.t -> unit [@bs.this]) -> unit 
+  method response : string
+end
+type x = _x Js.t 
+
+let f (x : x ) = 
+  begin 
+    x##onload #=  (fun [@bs.this] o -> Js.log o);
+    x##addEventListener "onload" begin fun [@bs.this] o -> 
+      Js.log o##response
+    end
+  end
+
diff --git a/lib/js/js_int64.js b/lib/js/js_int64.js
@@ -1,4 +1,4 @@
-// GENERATED CODE BY BUCKLESCRIPT VERSION 0.6.2 , PLEASE EDIT WITH CARE
+// GENERATED CODE BY BUCKLESCRIPT VERSION 0.7.0 , PLEASE EDIT WITH CARE
 'use strict';
 
 

diff --git a/lib/js/test/test_bs_this.js b/lib/js/test/test_bs_this.js
@@ -34,8 +34,22 @@ var js_obj = {
   }
 };
 
+function f(x) {
+  x.onload = function () {
+    var o = this ;
+    console.log(o);
+    return /* () */0;
+  };
+  return x.addEventListener("onload", function () {
+              var o = this ;
+              console.log(o.response);
+              return /* () */0;
+            });
+}
+
 exports.uux_this = uux_this;
 exports.even     = even;
 exports.bark     = bark;
 exports.js_obj   = js_obj;
+exports.f        = f;
 /* uux_this Not a pure module */