Merge pull request #5107 from rescript-lang/set_instance

Author: bobzhang

Diff for: jscomp/common/bs_version.ml

@@ -22,7 +22,7 @@
  * 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 version = "9.1.2"
+let version = "10.0.0"
 let header =
   "// Generated by ReScript, PLEASE EDIT WITH CARE"
 let package_name = ref "rescript"

Diff for: jscomp/common/js_config.ml

@@ -92,4 +92,6 @@ let as_ppx = ref false
 
 let customize_runtime = ref None 
 
-let as_pp = ref false
+let as_pp = ref false
+
+let self_stack : string Stack.t = Stack.create ()

Diff for: jscomp/common/js_config.mli

@@ -99,4 +99,6 @@ val as_ppx : bool ref
 
 
 val customize_runtime : string option ref 
-val as_pp: bool ref
+val as_pp: bool ref
+
+val self_stack : string Stack.t

Diff for: jscomp/frontend/ast_pat.ml

@@ -60,10 +60,13 @@ let rec labels_of_fun (e : Parsetree.expression)  =
 
 let rec is_single_variable_pattern_conservative  (p : t ) =
   match p.ppat_desc with 
-  | Parsetree.Ppat_any 
-  | Parsetree.Ppat_var _ -> true 
-  | Parsetree.Ppat_alias (p,_) 
+  | Parsetree.Ppat_any -> Some ""
+  | Parsetree.Ppat_var s -> Some s.txt 
+  | Parsetree.Ppat_alias (p, s) -> 
+    (* Check more complex patterns is needed or not*)
+    if is_single_variable_pattern_conservative p <> None then
+      Some s.txt      
+    else None
   | Parsetree.Ppat_constraint (p, _) -> 
     is_single_variable_pattern_conservative p 
-
-  | _ -> false
+  | _ -> None

Diff for: jscomp/frontend/ast_pat.mli

@@ -35,4 +35,5 @@ val labels_of_fun :
   Parsetree.expression -> 
   Asttypes.arg_label list
 
-val is_single_variable_pattern_conservative : t -> bool
+val is_single_variable_pattern_conservative : 
+  t -> string option 

Diff for: jscomp/frontend/ast_uncurry_gen.ml

@@ -26,8 +26,13 @@ open Ast_helper
 
 (* Handling `fun [@this]` used in `object [@bs] end` *)
 let to_method_callback  loc (self : Bs_ast_mapper.mapper) 
-    label pat body : Parsetree.expression_desc
+    label (self_pat : Parsetree.pattern) body : Parsetree.expression_desc
   = 
+  let self_pat = self.pat self self_pat in  
+  (match (Ast_pat.is_single_variable_pattern_conservative self_pat) with 
+  | None -> 
+     Bs_syntaxerr.err self_pat.ppat_loc  Bs_this_simple_pattern
+  | Some self -> Stack.push self Js_config.self_stack);  
   Bs_syntaxerr.optional_err loc label;  
   let rec aux acc (body : Parsetree.expression) = 
     match Ast_attributes.process_attributes_rev body.pexp_attributes with 
@@ -41,15 +46,13 @@ let to_method_callback  loc (self : Bs_ast_mapper.mapper)
       end 
     | _, _ -> self.expr self body, acc  
   in 
-  let first_arg = self.pat self pat in  
-  (if not  (Ast_pat.is_single_variable_pattern_conservative first_arg) then
-     Bs_syntaxerr.err first_arg.ppat_loc  Bs_this_simple_pattern);  
-  let result, rev_extra_args = aux [label,first_arg] body in 
+  let result, rev_extra_args = aux [label,self_pat] body in 
   let body = 
     Ext_list.fold_left rev_extra_args result (fun e (label,p) -> Ast_helper.Exp.fun_ ~loc label None p e )
   in
   let arity = List.length rev_extra_args in   
   let arity_s = string_of_int arity in 
+  Stack.pop Js_config.self_stack |> ignore;
   Parsetree.Pexp_apply 
     (Exp.ident ~loc {loc ; txt = Ldot(Ast_literal.Lid.js_oo,"unsafe_to_method")},
      [Nolabel,

Diff for: jscomp/frontend/bs_builtin_ppx.ml

@@ -81,6 +81,23 @@ let expr_mapper  (self : mapper) (e : Parsetree.expression) =
   (** Its output should not be rewritten anymore *)
   | Pexp_extension extension ->
     Ast_exp_extension.handle_extension e self extension
+  | Pexp_setinstvar ({txt;loc},expr) -> 
+    if Stack.is_empty Js_config.self_stack then 
+      Location.raise_errorf ~loc:e.pexp_loc "This assignment can only happen in object context";
+    let name = Stack.top Js_config.self_stack in   
+    if name = "" then 
+      Location.raise_errorf ~loc:e.pexp_loc 
+        "The current object does not assign a name";
+    let open Ast_helper in     
+    self.expr self 
+      (Exp.apply ~loc:e.pexp_loc 
+        (Exp.ident ~loc {loc; txt = Lident "#="})
+        [Nolabel,
+         (Exp.send  ~loc 
+            (Exp.ident ~loc {loc; txt = Lident name})
+            {loc ; txt});
+         Nolabel, expr
+         ])
   | Pexp_constant (
       Pconst_string
         (s, (Some delim)))

Diff for: jscomp/main/rescript_compiler_main.ml

@@ -448,9 +448,6 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array =
     "-nolabels", set Clflags.classic, 
     "*internal* Ignore non-optional labels in types";  
 
-    "-principal", set Clflags.principal, 
-    "*internal* Check principality of type inference";  
-
     "-short-paths", clear Clflags.real_paths, 
     "*internal* Shorten paths in types";
 

Diff for: jscomp/test/ppx_this_obj_field.js

@@ -213,6 +213,15 @@ eq("File \"ppx_this_obj_field.ml\", line 103, characters 5-12", [
       ]
     ]);
 
+var f = {
+  x: 3,
+  hei: (function () {
+      var y = this ;
+      y.x = y.x + 3 | 0;
+      
+    })
+};
+
 Mt.from_pair_suites("Ppx_this_obj_field", suites.contents);
 
 exports.suites = suites;
@@ -227,4 +236,5 @@ exports.eventObj = eventObj;
 exports.test__ = test__;
 exports.zz = zz;
 exports.test_type2 = test_type2;
+exports.f = f;
 /* v5 Not a pure module */

Diff for: jscomp/test/ppx_this_obj_field.ml

@@ -27,9 +27,9 @@ let v =
     val x = 3
     val mutable y = 0
     method private reset () = 
-      self##y#= 0 
+      y <- 0 
     method  incr () =
-      self##y #= (self##y + 1)
+      y <- self#y + 1
     (* TODO: the error message is confusing 
        {[
          self##y #= self##y + 1 
@@ -42,10 +42,10 @@ let v =
        it will not work if `self##y` is indeed a reference
        we need document this behavior
     *)
-    method getY () = self##y
-    method say () = self##x + self##y
+    method getY () = self#y
+    method say () = self#x + self#y
   end
-     
+
 
 let u = 
   object (self)
@@ -59,16 +59,16 @@ let test_type = [u ; v]
 let z : < getX : (unit -> int [@bs.meth]); setX : (int -> unit [@bs.meth]) >   =
   object (self)
     val x = ref 3 
-    method setX x = self##x := x
+    method setX x = self#x := x
     method getX () =  ! (self##x)
   end 
 
 let eventObj  : <
   empty : (unit -> unit [@bs.meth]);
-    needRebuild : (unit -> bool [@bs.meth]);
-    push : string  * string -> unit [@bs.meth]
-  >
-  
+  needRebuild : (unit -> bool [@bs.meth]);
+  push : string  * string -> unit [@bs.meth]
+>
+
   = 
   object (self)
     val events : (string * string) array = [||]
@@ -82,8 +82,8 @@ let test__ x = eventObj##push   x
 let zz : < getX : (unit -> int [@bs.meth]); setX : (int -> unit [@bs.meth]) > =
   object (self)
     val mutable x =  3 
-    method setX x = self##x #= x
-    method getX () =   (self##x)
+    method setX x = x <- x
+    method getX () =   self#x
   end 
 
 let test_type2 = [z;zz]
@@ -102,6 +102,13 @@ let () =
   let bb = z##getX () in
   eq __LOC__ ((3, 32), (aa,bb))
 
+
+let f = object (_ as y)
+  val mutable x =  3 
+  method hei () = 
+    x <- y#x + 3 
+
+end  
 let () =
   Mt.from_pair_suites __MODULE__ !suites
 

Diff for: lib/4.06.1/bsb.ml

@@ -55,7 +55,7 @@ end = struct
  * 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 version = "9.1.2"
+let version = "10.0.0"
 let header =
   "// Generated by ReScript, PLEASE EDIT WITH CARE"
 let package_name = ref "rescript"

Diff for: lib/4.06.1/rescript.ml

@@ -5940,7 +5940,7 @@ end = struct
  * 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 version = "9.1.2"
+let version = "10.0.0"
 let header =
   "// Generated by ReScript, PLEASE EDIT WITH CARE"
 let package_name = ref "rescript"

Diff for: lib/4.06.1/unstable/bspack.ml

@@ -11969,6 +11969,8 @@ val as_ppx : bool ref
 
 val customize_runtime : string option ref 
 val as_pp: bool ref
+
+val self_stack : string Stack.t
 end = struct
 #1 "js_config.ml"
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -12064,6 +12066,8 @@ let as_ppx = ref false
 let customize_runtime = ref None 
 
 let as_pp = ref false
+
+let self_stack : string Stack.t = Stack.create ()
 end
 module Map_gen : sig 
 #1 "map_gen.mli"

Diff for: lib/4.06.1/unstable/js_compiler.ml

@@ -17779,6 +17779,8 @@ val as_ppx : bool ref
 
 val customize_runtime : string option ref 
 val as_pp: bool ref
+
+val self_stack : string Stack.t
 end = struct
 #1 "js_config.ml"
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -17874,6 +17876,8 @@ let as_ppx = ref false
 let customize_runtime = ref None 
 
 let as_pp = ref false
+
+let self_stack : string Stack.t = Stack.create ()
 end
 module Bs_cmi_load
 = struct
@@ -18004,7 +18008,7 @@ end = struct
  * 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 version = "9.1.2"
+let version = "10.0.0"
 let header =
   "// Generated by ReScript, PLEASE EDIT WITH CARE"
 let package_name = ref "rescript"
@@ -399821,7 +399825,8 @@ val labels_of_fun :
   Parsetree.expression -> 
   Asttypes.arg_label list
 
-val is_single_variable_pattern_conservative : t -> bool
+val is_single_variable_pattern_conservative : 
+  t -> string option 
 
 end = struct
 #1 "ast_pat.ml"
@@ -399887,13 +399892,16 @@ let rec labels_of_fun (e : Parsetree.expression)  =
 
 let rec is_single_variable_pattern_conservative  (p : t ) =
   match p.ppat_desc with 
-  | Parsetree.Ppat_any 
-  | Parsetree.Ppat_var _ -> true 
-  | Parsetree.Ppat_alias (p,_) 
+  | Parsetree.Ppat_any -> Some ""
+  | Parsetree.Ppat_var s -> Some s.txt 
+  | Parsetree.Ppat_alias (p, s) -> 
+    (* Check more complex patterns is needed or not*)
+    if is_single_variable_pattern_conservative p <> None then
+      Some s.txt      
+    else None
   | Parsetree.Ppat_constraint (p, _) -> 
     is_single_variable_pattern_conservative p 
-
-  | _ -> false
+  | _ -> None
 
 end
 module Ast_typ_uncurry : sig 
@@ -403597,8 +403605,13 @@ open Ast_helper
 
 (* Handling `fun [@this]` used in `object [@bs] end` *)
 let to_method_callback  loc (self : Bs_ast_mapper.mapper) 
-    label pat body : Parsetree.expression_desc
+    label (self_pat : Parsetree.pattern) body : Parsetree.expression_desc
   = 
+  let self_pat = self.pat self self_pat in  
+  (match (Ast_pat.is_single_variable_pattern_conservative self_pat) with 
+  | None -> 
+     Bs_syntaxerr.err self_pat.ppat_loc  Bs_this_simple_pattern
+  | Some self -> Stack.push self Js_config.self_stack);  
   Bs_syntaxerr.optional_err loc label;  
   let rec aux acc (body : Parsetree.expression) = 
     match Ast_attributes.process_attributes_rev body.pexp_attributes with 
@@ -403612,15 +403625,13 @@ let to_method_callback  loc (self : Bs_ast_mapper.mapper)
       end 
     | _, _ -> self.expr self body, acc  
   in 
-  let first_arg = self.pat self pat in  
-  (if not  (Ast_pat.is_single_variable_pattern_conservative first_arg) then
-     Bs_syntaxerr.err first_arg.ppat_loc  Bs_this_simple_pattern);  
-  let result, rev_extra_args = aux [label,first_arg] body in 
+  let result, rev_extra_args = aux [label,self_pat] body in 
   let body = 
     Ext_list.fold_left rev_extra_args result (fun e (label,p) -> Ast_helper.Exp.fun_ ~loc label None p e )
   in
   let arity = List.length rev_extra_args in   
   let arity_s = string_of_int arity in 
+  Stack.pop Js_config.self_stack |> ignore;
   Parsetree.Pexp_apply 
     (Exp.ident ~loc {loc ; txt = Ldot(Ast_literal.Lid.js_oo,"unsafe_to_method")},
      [Nolabel,
@@ -405591,6 +405602,23 @@ let expr_mapper  (self : mapper) (e : Parsetree.expression) =
   (** Its output should not be rewritten anymore *)
   | Pexp_extension extension ->
     Ast_exp_extension.handle_extension e self extension
+  | Pexp_setinstvar ({txt;loc},expr) -> 
+    if Stack.is_empty Js_config.self_stack then 
+      Location.raise_errorf ~loc:e.pexp_loc "This assignment can only happen in object context";
+    let name = Stack.top Js_config.self_stack in   
+    if name = "" then 
+      Location.raise_errorf ~loc:e.pexp_loc 
+        "The current object does not assign a name";
+    let open Ast_helper in     
+    self.expr self 
+      (Exp.apply ~loc:e.pexp_loc 
+        (Exp.ident ~loc {loc; txt = Lident "#="})
+        [Nolabel,
+         (Exp.send  ~loc 
+            (Exp.ident ~loc {loc; txt = Lident name})
+            {loc ; txt});
+         Nolabel, expr
+         ])
   | Pexp_constant (
       Pconst_string
         (s, (Some delim)))