add first class js object support so people can create js object

jscomp/syntax/ast_attributes.ml

@@ -101,7 +101,7 @@ let process_attributes_rev (attrs : t) =
         st, attr::acc 
     ) ( `Nothing, []) attrs
 
-let process_class_type_decl_rev attrs = 
+let process_bs attrs = 
   List.fold_left (fun (st, acc) (({txt; loc}, _) as attr : attr) -> 
       match txt, st  with 
       | "bs", _

jscomp/syntax/ast_attributes.mli

@@ -35,7 +35,7 @@ val process_method_attributes_rev :
 val process_attributes_rev : 
   t -> [ `Meth_callback | `Nothing | `Uncurry | `Method ] * t 
 
-val process_class_type_decl_rev : 
+val process_bs : 
   t -> [ `Nothing | `Has] * t 
 
 val process_external : t -> bool 

jscomp/syntax/ast_core_type.ml

@@ -150,3 +150,6 @@ let from_labels ~loc tyvars (labels : string list)
     (fun label tyvar acc -> Typ.arrow ~loc label tyvar acc) labels tyvars  result_type
 
 
+let make_obj ~loc xs =
+  Ast_comb.to_js_type loc @@
+  Ast_helper.Typ.object_  ~loc xs   Closed

jscomp/syntax/ast_core_type.mli

@@ -57,3 +57,7 @@ val string_type : t -> arg_type
 val from_labels :
   loc:Location.t -> t list -> string list -> t
 
+val make_obj :
+  loc:Location.t ->
+  (string * Parsetree.attributes * t) list ->
+  t

jscomp/syntax/ast_external.mli

@@ -29,7 +29,7 @@ val create_local_external : Location.t ->
   pval_type:Parsetree.core_type ->
   ?local_module_name:string ->
   ?local_fun_name:string ->
-  (Asttypes.label * Parsetree.expression) list -> Parsetree.expression_desc
+  (string * Parsetree.expression) list -> Parsetree.expression_desc
 
 val local_extern_cont : 
   Location.t ->

jscomp/syntax/ast_external_attributes.ml

@@ -433,8 +433,7 @@ let handle_attributes
      | Obj_create arg_labels ,  {ptyp_desc = Ptyp_any; _}
        ->
        let result =
-         Ast_comb.to_js_type loc @@
-         Ast_helper.Typ.object_  ~loc   (
+         Ast_core_type.make_obj ~loc (
          List.fold_right2  (fun arg label acc ->
            match arg, label with
            | (_, ty), Ast_core_type.Label s
@@ -451,7 +450,7 @@ let handle_attributes
                | _ -> assert false                 
              end                 
            | (_, _), Ast_core_type.Empty -> acc                
-           ) arg_types_ty arg_labels []) Closed  in
+           ) arg_types_ty arg_labels [])  in
        Ast_core_type.replace_result type_annotation result 
      | _, _ -> type_annotation) ,
     (match ffi , prim_name with

jscomp/syntax/ast_util.ml

@@ -370,6 +370,135 @@ let handle_raw_structure loc payload =
   end
 
 
+(* let method_type_of_method (e  : Parsetree.expression) = *)
+(*   match e.pexp_desc with *)
+(*   | Pexp_function (arg, body) -> *)
+(*     arrow ~loc  *)
+(*   | Pexp_fun  *)
+
+(*   |  _  ->  *)
+(** Attention: we should avoid type variable conflict for each method   *)
+(* Since the method name is unique, there would be no conflict *)
+(* Note mapper is only for API compatible *)  
+let self_type loc = Typ.var ~loc "self_type"   
+
+let generate_callback_method_pair loc
+    (mapper : Ast_mapper.mapper) method_name arity
+  : (Ast_core_type.t * Ast_core_type.t)  =
+  let result = Typ.var ~loc method_name in   
+  let tyvars =
+    Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+  in
+  let self_type = self_type loc in  
+  if arity = 0 then
+    to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result ,
+    to_method_callback_type loc mapper  "" self_type result      
+  else
+    begin match tyvars with
+    | x :: rest ->
+      let method_rest =
+        List.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)  rest result in         
+      (to_method_type loc mapper "" x method_rest,
+       to_method_callback_type loc mapper  "" self_type
+         (Typ.arrow ~loc "" x method_rest))
+    | _ -> assert false
+    end         
+
+let arity_of_method_fun
+    (pat : Parsetree.pattern)
+    (e : Parsetree.expression) =
+  let rec aux (e : Parsetree.expression)  =
+    match e.pexp_desc with
+    | Pexp_fun ("", None, pat, e) ->
+      1 + aux e       
+    | Pexp_fun _
+      -> Location.raise_errorf ~loc:e.pexp_loc "Lable is not allowed in JS object"
+    | _ -> 0 in
+  (match pat.ppat_desc with
+  | Ppat_construct ({txt = Lident "()"}, None)
+    ->  0
+  | _ -> 1 ) + aux e
+
+let ocaml_obj_as_js_object
+    loc (mapper : Ast_mapper.mapper)
+    (self_pat : Parsetree.pattern)
+    (clfs : Parsetree.class_field list) =
+
+  let (labels,  label_types, method_types, exprs) =
+    List.fold_right
+      (fun (x  : Parsetree.class_field)
+        (labels,
+         label_types,
+         method_types,
+         exprs) ->
+         match x.pcf_desc with
+         | Pcf_method (
+             label,
+             _private_flag,
+             Cfk_concrete
+               (_override_flag,
+                (
+                  {
+                    pexp_desc =
+                      Pexp_poly
+                        (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
+                         None)}))                       
+                      )
+           ->
+           let arity = arity_of_method_fun pat e in
+           let method_type, label_type =
+             generate_callback_method_pair x.pcf_loc mapper label.txt arity in 
+           (label::labels,
+            label_type::label_types,
+            method_type :: method_types,
+            {f with
+             pexp_desc =
+               let f =
+                 match pat.ppat_desc with
+                 | Ppat_construct ({txt = Lident "()"}, None) -> e 
+                 | _ -> f in                       
+               to_method_callback loc mapper self_pat f
+           } :: exprs)
+         | Pcf_method _           
+         | Pcf_inherit _ 
+         | Pcf_val _ 
+         | Pcf_initializer _
+         | Pcf_attribute _
+         | Pcf_extension _
+         | Pcf_constraint _ ->
+           Location.raise_errorf
+             ~loc:x.pcf_loc "Only method support currently"
+      ) clfs  ([], [], [],  []) in
+  let result_type =
+    Typ.alias ~loc (Ast_core_type.make_obj  ~loc
+      (List.map2 (fun label method_type ->
+           label.Asttypes.txt , [], method_type           
+         ) labels method_types)) "self_type"  in      
+  let pval_type =
+    List.fold_right2
+      (fun label label_type acc ->
+         Typ.arrow
+           ~loc:label.Asttypes.loc
+           label.Asttypes.txt
+           label_type acc           
+      ) labels label_types result_type in
+  let pval_attributes = Ast_attributes.bs_obj pval_type in
+  let local_fun_name = "mk" in  
+  let pval_type, pval_prim =
+    Ast_external_attributes.handle_attributes_as_string
+      loc
+      local_fun_name      
+      pval_type pval_attributes "" in
+  Ast_external.local_extern_cont
+    loc
+    ~pval_attributes
+    ~pval_prim
+    ~local_fun_name
+    (fun e ->
+       Exp.apply ~loc e
+         (List.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
+    ~pval_type
+
 let record_as_js_object 
     loc 
     (self : Ast_mapper.mapper)

jscomp/syntax/ast_util.mli

@@ -118,3 +118,8 @@ val handle_raw :
 
 val handle_raw_structure : 
   loc -> Ast_payload.t -> Parsetree.structure_item
+
+val ocaml_obj_as_js_object :
+  (Parsetree.pattern ->
+   Parsetree.class_field list ->
+   Parsetree.expression_desc) cxt   

jscomp/syntax/ppx_entry.ml

@@ -446,13 +446,25 @@ let rec unsafe_mapper : Ast_mapper.mapper =
             }
           else 
             Ast_mapper.default_mapper.expr  self e
+        | Pexp_object {pcstr_self;  pcstr_fields} ->
+          begin match Ast_attributes.process_bs e.pexp_attributes with
+            | `Has, pexp_attributes
+              ->
+              {e with
+               pexp_desc = 
+                 Ast_util.ocaml_obj_as_js_object
+                   loc self pcstr_self pcstr_fields;
+               pexp_attributes               
+              }                          
+            | `Nothing , _ ->
+              Ast_mapper.default_mapper.expr  self e              
+          end            
         | _ ->  Ast_mapper.default_mapper.expr self e
       );
     typ = (fun self typ -> handle_typ Ast_mapper.default_mapper self typ);
     class_type = 
       (fun self ({pcty_attributes} as ctd) -> 
-         match Ast_attributes.process_class_type_decl_rev 
-                 pcty_attributes with 
+         match Ast_attributes.process_bs pcty_attributes with 
          | `Nothing,  _ -> 
            Ast_mapper.default_mapper.class_type
              self ctd 

jscomp/test/.depend

@@ -434,6 +434,8 @@ polyvar_test.cmj : ../runtime/js.cmj
 polyvar_test.cmx : ../runtime/js.cmx
 ppx_apply_test.cmj : mt.cmi
 ppx_apply_test.cmx : mt.cmx
+ppx_this_obj.cmj : mt.cmi
+ppx_this_obj.cmx : mt.cmx
 pq_test.cmj :
 pq_test.cmx :
 pr6726.cmj :
@@ -1182,6 +1184,8 @@ polyvar_test.cmo : ../runtime/js.cmo
 polyvar_test.cmj : ../runtime/js.cmj
 ppx_apply_test.cmo : mt.cmi
 ppx_apply_test.cmj : mt.cmj
+ppx_this_obj.cmo : mt.cmi
+ppx_this_obj.cmj : mt.cmj
 pq_test.cmo :
 pq_test.cmj :
 pr6726.cmo :

jscomp/test/Makefile

@@ -58,7 +58,8 @@ OTHERS := a test_ari test_export2 test_internalOO test_obj_simple_ffi test_scope
 	mutual_non_recursive_type external_ppx \
 	optional_ffi_test poly_variant_test \
 	bs_rest_test infer_type_test fs_test module_as_function\
-	test_case_set test_mutliple string_bound_get_test inline_string_test
+	test_case_set test_mutliple string_bound_get_test inline_string_test\
+	ppx_this_obj	
 
 
 SOURCE_LIST := js_dyn $(OTHERS) 

jscomp/test/ppx_this_obj.js

@@ -0,0 +1,54 @@
+'use strict';
+
+var Mt    = require("./mt");
+var Block = require("../../lib/js/block");
+
+var suites = [/* [] */0];
+
+var test_id = [0];
+
+function eq(loc, param) {
+  var y = param[1];
+  var x = param[0];
+  test_id[0] = test_id[0] + 1 | 0;
+  suites[0] = /* :: */[
+    /* tuple */[
+      loc + (" id " + test_id[0]),
+      function () {
+        return /* Eq */Block.__(0, [
+                  x,
+                  y
+                ]);
+      }
+    ],
+    suites[0]
+  ];
+  return /* () */0;
+}
+
+var v = {
+  x: function () {
+    return 3;
+  },
+  say: function (x) {
+    var self = this ;
+    return x * self.x();
+  },
+  hi: function (x, y) {
+    var self = this ;
+    return self.say(x) + y;
+  }
+};
+
+eq('File "ppx_this_obj.ml", line 25, characters 5-12', /* tuple */[
+      11,
+      v.hi(3, 2)
+    ]);
+
+Mt.from_pair_suites("ppx_this_obj.ml", suites[0]);
+
+exports.suites  = suites;
+exports.test_id = test_id;
+exports.eq      = eq;
+exports.v       = v;
+/* v Not a pure module */

jscomp/test/ppx_this_obj.ml

@@ -0,0 +1,27 @@
+let suites :  Mt.pair_suites ref  = ref []
+let test_id = ref 0
+let eq loc (x, y) = 
+  incr test_id ; 
+  suites := 
+    (loc ^" id " ^ (string_of_int !test_id), (fun _ -> Mt.Eq(x,y))) :: !suites
+
+let v  = 
+  let x = 3. in
+  object (self)
+    method x () = x
+    method say x = x *. self## x ()
+    method hi x y = self##say x +. y                      
+  end [@bs]
+(** compile infer 
+class type js_obj =  object
+  method x : unit -> float
+  method say : float -> float
+  method hi : float -> float -> float
+end [@bs]  
+val js_obj : js_obj Js.t
+*)
+
+let () =
+  eq __LOC__ (11., v##hi 3. 2.)
+
+let () = Mt.from_pair_suites __FILE__ !suites

jscomp/test/unsafe_obj_external.js

@@ -1,4 +1,4 @@
-// GENERATED CODE BY BUCKLESCRIPT VERSION 0.9.0 , PLEASE EDIT WITH CARE
+// GENERATED CODE BY BUCKLESCRIPT VERSION 0.9.1 , PLEASE EDIT WITH CARE
 'use strict';
 
 

jscomp/test/unsafe_obj_external.ml

@@ -4,7 +4,6 @@
 external config :
   x : ('self_type -> 'x [@bs.this]) ->
   say :('self_type  -> 'x -> 'say [@bs.this]) ->
-  unit ->
   (<
      x : unit -> 'x [@bs.meth];
      say : 'x -> 'say [@bs.meth]      
@@ -16,12 +15,12 @@ let v =
   config
     ~x:(fun [@bs.this] _ -> x )
     ~say:(fun [@bs.this] self x -> self##x () + x)
-    ()
+
 
 (** 
 let x = 3 in
 object (self : 'self_type)
-   method x = x 
+   method x () = x 
    method say x = self##x + x 
 end [@bs]
 *)