replace [x##height_set 3] with x##height #= 3

jscomp/common/literals.ml

@@ -51,10 +51,12 @@ let stdlib = "stdlib"
 
 let imul = "imul" (* signed int32 mul *)
 
-let setter_suffix = "_set"
+let setter_suffix = "#="
 let setter_suffix_len = String.length setter_suffix
 
 let case = "case"
 let case_set = "case_set"
 let case_prefix = "case_"
 
+let js_fn_run = "js_fn_run"
+let js_method_run = "js_method_run"

jscomp/common/literals.mli

@@ -56,3 +56,6 @@ val setter_suffix_len : int
 val case : string 
 val case_set : string 
 val case_prefix : string
+
+val js_fn_run : string
+val js_method_run : string

jscomp/lam.ml

@@ -513,7 +513,7 @@ let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t =
   | _ -> default ()
 
 
-let not x : t = 
+let not_ x : t = 
   prim Pnot [x] 
 
 let lam_prim ~primitive:(p : Lambda.primitive) ~args  : t = 
@@ -568,24 +568,20 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args  : t =
 
   | Pccall a -> 
     let prim_name = a.prim_name in
-    begin match prim_name with 
-    |  "js_debugger"
-      -> prim ~primitive:Pdebugger ~args 
-    | "js_fn_run" 
-      -> 
-      prim ~primitive:(Pjs_fn_run (int_of_string a.prim_native_name)) ~args 
-    |  "js_fn_mk"  
-      -> 
-      prim ~primitive:(Pjs_fn_make (int_of_string a.prim_native_name)) ~args           
-    | "js_fn_method"
-      ->
-      prim ~primitive:(Pjs_fn_method (int_of_string a.prim_native_name)) ~args           
-    | "js_fn_runmethod"
-      ->
-      prim ~primitive:(Pjs_fn_runmethod (int_of_string a.prim_native_name)) ~args           
-    | _ -> 
+    if Pervasives.not @@ Ext_string.starts_with prim_name "js_" then 
+      prim ~primitive:(Pccall a ) ~args else 
+    if prim_name =  "js_debugger" then 
+      prim ~primitive:Pdebugger ~args else 
+    if prim_name =  Literals.js_fn_run || prim_name = Literals.js_method_run then
+      prim ~primitive:(Pjs_fn_run (int_of_string a.prim_native_name)) ~args else 
+    if prim_name = "js_fn_mk" then 
+      prim ~primitive:(Pjs_fn_make (int_of_string a.prim_native_name)) ~args else                
+    if prim_name = "js_fn_method" then 
+      prim ~primitive:(Pjs_fn_method (int_of_string a.prim_native_name)) ~args else
+    if prim_name = "js_fn_runmethod" then 
+      prim ~primitive:(Pjs_fn_runmethod (int_of_string a.prim_native_name)) ~args 
+    else
       prim ~primitive:(Pccall a) ~args
-    end
   | Praise _ ->
     if Js_config.get_no_any_assert () then 
       begin match args with 

jscomp/lam.mli

@@ -220,7 +220,7 @@ val unit : t
 
 val sequor : binop
 val sequand : binop
-val not : unop
+val not_ : unop
 val seq : binop
 val while_ : binop
 val event : t -> Lambda.lambda_event -> t  

jscomp/lam_compile.ml

@@ -830,6 +830,7 @@ and
                   cont  block0 block1 (Some obj_code) (E.access (E.var obj) value)
               else if  Ext_string.ends_with method_name Literals.setter_suffix then 
                 let property =
+                  Lam_methname.translate ~loc @@ 
                   String.sub method_name 0 
                     (String.length method_name - Literals.setter_suffix_len) in 
                 match Js_ast_util.named_expression  obj with

jscomp/lam_pass_remove_alias.ml

@@ -71,13 +71,13 @@ let simplify_alias
         let l1 = 
           match x with 
           | Null 
-            -> Lam.not ( Lam.prim ~primitive:Lam.Prim.js_is_nil ~args:[l]) 
+            -> Lam.not_ ( Lam.prim ~primitive:Lam.Prim.js_is_nil ~args:[l]) 
           | Undefined 
             -> 
-            Lam.not (Lam.prim ~primitive:Lam.Prim.js_is_undef ~args:[l])
+            Lam.not_ (Lam.prim ~primitive:Lam.Prim.js_is_undef ~args:[l])
           | Null_undefined
             -> 
-            Lam.not
+            Lam.not_
               ( Lam.prim ~primitive:Lam.Prim.js_is_nil_undef  ~args:[l]) 
           | Normal ->  l1 
         in 

jscomp/runtime/js.ml

@@ -27,8 +27,8 @@ type (-'obj, +'a) meth_callback
 type +'a t (** Js object type *)
 
 
-
-type (-'arg, + 'result)fn (** Js uncurried function *)
+type (-'arg, + 'result) meth
+type (-'arg, + 'result) fn (** Js uncurried function *)
 
 (** This file will also be exported to external users 
     Attention: it should not have any code, all its code will be inlined so that 

jscomp/syntax/ast_literal.ml

@@ -37,6 +37,9 @@ module Lid = struct
   let js_fn = Longident.Ldot (Lident "Js", "fn")
   let pervasives_fn = Longident.Ldot (Lident "Pervasives", "fn")
 
+  let js_meth = Longident.Ldot (Lident "Js", "meth")
+  let pervasives_meth = Longident.Ldot (Lident "Pervasives", "meth")
+
   let pervasives_meth_callback = Longident.Ldot (Lident "Pervasives", "meth_callback")
   let js_obj = Longident.Ldot (Lident "Js", "t") 
 

jscomp/syntax/ast_literal.mli

@@ -30,8 +30,11 @@ module Lid : sig
   val type_unit : t 
   val pervasives_js_obj : t 
 
-  val pervasives_fn : t 
   val js_fn : t 
+  val pervasives_fn : t 
+
+  val js_meth : t 
+  val pervasives_meth : t 
 
   val pervasives_meth_callback : t
   val js_meth_callback : t 

jscomp/syntax/ast_util.ml

@@ -35,8 +35,19 @@ let curry_type_id () =
   else 
     Ast_literal.Lid.js_fn
 
-let mk_args ~loc n tys = 
+let method_id () = 
+  if Js_config.get_env () = Browser then 
+     Ast_literal.Lid.pervasives_meth
+  else 
+    Ast_literal.Lid.js_meth
+
+let meth_call_back_id () = 
+  if Js_config.get_env () = Browser then 
+    Ast_literal.Lid.pervasives_meth_callback
+  else 
+    Ast_literal.Lid.js_meth_callback
 
+let mk_args ~loc n tys = 
   Typ.variant ~loc 
     [ Rtag ("Args_" ^ string_of_int n, [], (tys = []),  tys)] Closed None
 
@@ -50,22 +61,27 @@ let lift_curry_type  ~loc args result  =
   in 
   Typ.constr ~loc {txt = curry_type_id (); loc} xs
 
+let lift_method_type  ~loc args result  = 
+  let xs =
+    match args with 
+    | [ ] -> [mk_args 0  ~loc [] ; result ]
+    | [ x ] -> [ mk_args ~loc 1 [x] ; result ] 
+    | _ -> 
+      [mk_args ~loc (List.length args ) [Typ.tuple ~loc args] ; result ]
+  in 
+  Typ.constr ~loc {txt = method_id (); loc} xs
+
 let lift_js_type ~loc  x  = 
   Typ.constr ~loc {txt = js_obj_type_id (); loc} [x]
 
-let meth_type_id () = 
-  if Js_config.get_env () = Browser then 
-    Ast_literal.Lid.pervasives_meth_callback
-  else 
-    Ast_literal.Lid.js_meth_callback
 
 
 let arrow = Typ.arrow
 
 
 
 let lift_js_meth_callback ~loc (obj,meth) 
-  = Typ.constr ~loc {txt = meth_type_id () ; loc} [obj; meth]
+  = Typ.constr ~loc {txt = meth_call_back_id () ; loc} [obj; meth]
 
 let down_with_name ~loc obj name =
   let downgrade ~loc () = 
@@ -80,13 +96,21 @@ let down_with_name ~loc obj name =
     (fun down -> Exp.send ~loc (Exp.apply ~loc down ["", obj]) name  )
 
 let gen_fn_run loc arity fn args  : Parsetree.expression_desc = 
-  let pval_prim = ["js_fn_run" ; string_of_int arity]  in
+  let pval_prim = [Literals.js_fn_run ; string_of_int arity]  in
   let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity  in 
   let pval_type =
     arrow ~loc "" (lift_curry_type ~loc args_type result_type) fn_type in 
   Ast_comb.create_local_external loc ~pval_prim ~pval_type 
     (("", fn) :: List.map (fun x -> "",x) args )
 
+let gen_method_run loc arity fn args  : Parsetree.expression_desc = 
+  let pval_prim = [Literals.js_method_run ; string_of_int arity]  in
+  let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity  in 
+  let pval_type =
+    arrow ~loc "" (lift_method_type ~loc args_type result_type) fn_type in 
+  Ast_comb.create_local_external loc ~pval_prim ~pval_type 
+    (("", fn) :: List.map (fun x -> "",x) args )
+
 
 let fn_run loc fn args 
     (mapper : Ast_mapper.mapper) 
@@ -109,6 +133,35 @@ let fn_run loc fn args
      pexp_attributes 
     }
 
+let property_run loc (obj : Parsetree.expression) 
+    name (args : (string * Parsetree.expression) list ) e 
+    (mapper : Ast_mapper.mapper) : Parsetree.expression = 
+  let obj = mapper.expr mapper obj in
+  let args =
+    List.map (fun (label,e) ->
+        if label <> "" then
+          Location.raise_errorf ~loc "label is not allowed here"        ;
+        mapper.expr mapper e
+      ) args in
+  let len = List.length args in 
+  (* TODO: have a final checking for property arities 
+     [case], [case_set] and other setter       
+  *)
+  match args with 
+  | [ {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)}]
+    -> 
+    {e with pexp_desc = 
+              gen_fn_run loc 0
+                (Exp.mk ~loc @@ down_with_name ~loc obj name)
+                []
+    }
+  | _ -> 
+    {e with pexp_desc = 
+              gen_fn_run loc len 
+                (Exp.mk ~loc @@ down_with_name ~loc obj name)
+                args
+    }
+
 let method_run loc (obj : Parsetree.expression) 
     name (args : (string * Parsetree.expression) list ) e 
     (mapper : Ast_mapper.mapper) : Parsetree.expression = 
@@ -134,13 +187,13 @@ let method_run loc (obj : Parsetree.expression)
   | [ {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)}]
     -> 
     {e with pexp_desc = 
-              gen_fn_run loc 0
+              gen_method_run loc 0
                 (Exp.mk ~loc @@ down_with_name ~loc obj name)
                 []
     }
   | _ -> 
     {e with pexp_desc = 
-              gen_fn_run loc len 
+              gen_method_run loc len 
                 (Exp.mk ~loc @@ down_with_name ~loc obj name)
                 args
     }
@@ -194,6 +247,28 @@ let process_attributes_rev (attrs : Parsetree.attributes) =
         (attr::acc , st)
     ) ([], `Nothing) attrs
 
+type ('a,'b) st = 
+  { get : 'a option ; 
+    set : 'b option }
+
+
+let process_method_attributes_rev (attrs : Parsetree.attributes) = 
+  List.fold_left (fun (acc, st) ((tag, payload) as attr) -> 
+
+      match tag.Location.txt  with 
+      | "bs.get" (* [@@bs.get{null; undefined}]*)
+        -> 
+        (acc, {st with get = Some payload} )
+
+      | "bs.set"
+        -> (* properties -- void 
+              [@@bs.set{only}]
+           *)
+          acc, {st with set = Some payload }
+      | _ -> 
+        (attr::acc , st)
+    ) ([], {get = None ; set = None}) attrs
+
 
 (** TODO: how to handle attributes *)
 let destruct_arrow loc (first_arg : Parsetree.core_type) 
@@ -228,8 +303,41 @@ let destruct_arrow loc (first_arg : Parsetree.core_type)
     -> 
     lift_curry_type ~loc (List.rev rev_extra_args) result 
 
+
+let destruct_arrow_as_meth_type loc (first_arg : Parsetree.core_type) 
+    (typ : Parsetree.core_type) (mapper : Ast_mapper.mapper) = 
+  let rec aux acc (typ : Parsetree.core_type) = 
+    (* in general, 
+       we should collect [typ] in [int -> typ] before transformation, 
+       however: when attributes [fn] and [meth_callback] found in typ, 
+       we should stop 
+    *)
+    match process_attributes_rev typ.ptyp_attributes with 
+    | _ , `Nothing -> 
+      begin match typ.ptyp_desc with 
+      | Ptyp_arrow (label, arg, body)
+        -> 
+        if label <> "" then
+          Location.raise_errorf ~loc:typ.ptyp_loc "label is not allowed";
+        aux (mapper.typ mapper arg :: acc) body 
+      | _ -> mapper.typ mapper typ, acc 
+      end
+    | _, _ -> mapper.typ mapper typ, acc  
+  in 
+  let first_arg = mapper.typ mapper first_arg in
+  let result, rev_extra_args = 
+    aux  [first_arg] typ in 
+
+  match rev_extra_args with 
+  | [{ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, [])}]
+    ->
+    lift_method_type ~loc [] result 
+  | _
+    -> 
+    lift_method_type ~loc (List.rev rev_extra_args) result 
+
 
-let destruct_arrow_as_meth loc (first_arg : Parsetree.core_type) 
+let destruct_arrow_as_meth_callback_type loc (first_arg : Parsetree.core_type) 
     (typ : Parsetree.core_type) (mapper : Ast_mapper.mapper) = 
   let rec aux acc (typ : Parsetree.core_type) = 
     match process_attributes_rev typ.ptyp_attributes with 

jscomp/syntax/ast_util.mli

@@ -38,10 +38,26 @@ val method_run :
   (string * Parsetree.expression) list ->
   Parsetree.expression -> Ast_mapper.mapper -> Parsetree.expression
 
+val property_run : 
+  Ast_helper.loc ->
+  Parsetree.expression ->
+  string ->
+  (string * Parsetree.expression) list ->
+  Parsetree.expression -> Ast_mapper.mapper -> Parsetree.expression
+
+
 val process_attributes_rev : 
   Parsetree.attributes ->
   Parsetree.attributes * [ `Meth | `Nothing | `Uncurry ]
 
+type ('a,'b) st = 
+  { get : 'a option ; 
+    set : 'b option }
+
+val process_method_attributes_rev : 
+  Parsetree.attributes ->
+  Parsetree.attribute list * (Parsetree.payload, Parsetree.payload) st
+
 (** turn {[ fun [@fn] (x,y) -> x]} into an uncurried function 
     TODO: Future 
     {[ fun%bs this (a,b,c) -> 
@@ -68,7 +84,12 @@ val destruct_arrow :
   Parsetree.core_type ->
   Parsetree.core_type -> Ast_mapper.mapper -> Parsetree.core_type
 
-val destruct_arrow_as_meth : 
+val destruct_arrow_as_meth_type : 
+  Ast_helper.loc ->
+  Parsetree.core_type ->
+  Parsetree.core_type -> Ast_mapper.mapper -> Parsetree.core_type
+
+val destruct_arrow_as_meth_callback_type : 
   Ast_helper.loc ->
   Parsetree.core_type ->
   Parsetree.core_type -> Ast_mapper.mapper -> Parsetree.core_type