[feature] address #414

rescript-lang · May 25, 2016 · 72bf1fa · 72bf1fa
1 parent 6144a88
commit 72bf1fa
Show file tree

Hide file tree

Showing 6 changed files with 93 additions and 20 deletions.
diff --git a/jscomp/ppx_entry.ml b/jscomp/ppx_entry.ml
@@ -150,6 +150,8 @@ let create_local_external loc
        pexp_loc = loc
      })
 
+let record_as_js_object = ref None (* otherwise has an attribute *)
+let obj_type_as_js_obj_type = ref false
 let handle_record_as_js_object 
     loc 
     attr
@@ -352,25 +354,48 @@ let handle_typ
     ptyp_attributes ;
     ptyp_loc = loc 
     } -> 
-    let methods = List.map (fun (label, ptyp_attrs, core_type ) -> 
-        match find_uncurry_attrs_and_remove ptyp_attrs with 
-        | None, _ -> label, ptyp_attrs , self.typ self core_type
-        | Some v, ptyp_attrs -> 
-          label , ptyp_attrs, self.typ self 
-            { core_type with ptyp_attributes = v :: core_type.ptyp_attributes}
-      ) methods in           
     begin match Ext_list.exclude_with_fact (function 
       | {Location.txt = "bs.obj" ; _}, _  -> true 
       | _  -> false ) ptyp_attributes with 
-    |  None, _  ->
-      {ty with ptyp_desc = Ptyp_object (methods, closed_flag)}
     | Some _, ptyp_attributes -> 
+      let methods = 
+        Ext_ref.protect obj_type_as_js_obj_type true begin fun _ -> 
+          List.map (fun (label, ptyp_attrs, core_type ) -> 
+              match find_uncurry_attrs_and_remove ptyp_attrs with 
+              | None, _ -> label, ptyp_attrs , self.typ self core_type
+              | Some v, ptyp_attrs -> 
+                label , ptyp_attrs, self.typ self 
+                  { core_type with ptyp_attributes = v :: core_type.ptyp_attributes}
+            ) methods 
+        end
+      in           
+
       {ptyp_desc = 
          Ptyp_constr ({ txt = js_obj_type_id () ; loc},
                       [{ ty with ptyp_desc = Ptyp_object(methods, closed_flag);
                                  ptyp_attributes }]);
        ptyp_attributes = [];
        ptyp_loc = loc }
+    |  None, _  ->
+      let methods = 
+        List.map (fun (label, ptyp_attrs, core_type ) -> 
+            match find_uncurry_attrs_and_remove ptyp_attrs with 
+            | None, _ -> label, ptyp_attrs , self.typ self core_type
+            | Some v, ptyp_attrs -> 
+              label , ptyp_attrs, self.typ self 
+                { core_type with ptyp_attributes = v :: core_type.ptyp_attributes}
+          ) methods 
+      in           
+      if !obj_type_as_js_obj_type then 
+        {ptyp_desc = 
+           Ptyp_constr ({ txt = js_obj_type_id () ; loc},
+                        [{ ty with ptyp_desc = Ptyp_object(methods, closed_flag);
+                                   ptyp_attributes }]);
+         ptyp_attributes = [];
+         ptyp_loc = loc }
+      else 
+        {ty with ptyp_desc = Ptyp_object (methods, closed_flag)}
+
     end
   | _ -> super.typ self ty
 
@@ -708,12 +733,22 @@ let rec unsafe_mapper : Ast_mapper.mapper =
                 e.pexp_attributes
             with 
           | Some attr, pexp_attributes -> 
-            { e with
-              pexp_desc =  handle_record_as_js_object e.pexp_loc attr label_exprs mapper;
-              pexp_attributes 
-            }
+            Ext_ref.protect record_as_js_object (Some attr) begin fun () -> 
+              { e with
+                pexp_desc =  handle_record_as_js_object e.pexp_loc attr label_exprs mapper;
+                pexp_attributes 
+              }
+            end
           | None , _ -> 
-            Ast_mapper.default_mapper.expr  mapper e
+            begin match !record_as_js_object with 
+            | Some attr 
+              -> 
+              { e with
+                pexp_desc =  handle_record_as_js_object e.pexp_loc attr label_exprs mapper;
+              }
+            | None -> 
+              Ast_mapper.default_mapper.expr  mapper e
+            end
           end
         | _ ->  Ast_mapper.default_mapper.expr  mapper e
       );

diff --git a/jscomp/test/.depend b/jscomp/test/.depend
@@ -333,6 +333,8 @@ mt.cmj : ../stdlib/list.cmi mt.cmi
 mt.cmx : ../stdlib/list.cmx mt.cmi
 mt_global.cmj : mt.cmi mt_global.cmi
 mt_global.cmx : mt.cmx mt_global.cmi
+nested_obj_test.cmj :
+nested_obj_test.cmx :
 number_lexer.cmj : ../stdlib/sys.cmi ../stdlib/lexing.cmi
 number_lexer.cmx : ../stdlib/sys.cmx ../stdlib/lexing.cmx
 obj_literal_ppx.cmj : ../stdlib/array.cmi
@@ -987,6 +989,8 @@ mt.cmo : ../stdlib/list.cmi mt.cmi
 mt.cmj : ../stdlib/list.cmj mt.cmi
 mt_global.cmo : mt.cmi mt_global.cmi
 mt_global.cmj : mt.cmj mt_global.cmi
+nested_obj_test.cmo :
+nested_obj_test.cmj :
 number_lexer.cmo : ../stdlib/sys.cmi ../stdlib/lexing.cmi
 number_lexer.cmj : ../stdlib/sys.cmj ../stdlib/lexing.cmj
 obj_literal_ppx.cmo : ../stdlib/array.cmi

diff --git a/jscomp/test/demo.ml b/jscomp/test/demo.ml
@@ -84,11 +84,11 @@ class type grid  =
   object [@uncurry]
     inherit widget
     inherit measure
-    method columns__set : <width : int; .. >  Js.t array -> unit 
+    method columns__set : (<width : int; .. > [@bs.obj])  array -> unit 
     method titleRows__set : 
-      <label : <text : string; .. >  Js.t ; ..> Js.t   array -> unit 
+      (<label : <text : string; .. >   ; ..>  [@bs.obj])   array -> unit 
     method dataSource__set :
-      <label : <text : string; .. > Js.t  ; ..> Js.t  array array -> unit  
+      (<label : <text : string; .. >   ; ..> [@bs.obj])  array array -> unit  
   end
 
 external set_interval : (unit -> unit [@uncurry]) -> float -> unit  =  "setInterval"
@@ -186,8 +186,10 @@ let ui_layout
     stackPanel##addChild grid;
     stackPanel##addChild inputCode;
     stackPanel##addChild button;
-
-    let mk_titleRow text = {label =  {text } [@bs.obj] }[@bs.obj] in
+    (* {label =  {text } [@bs.obj] }[@bs.obj] 
+       should also work 
+    *)
+    let mk_titleRow text = {label =  {text }  }[@bs.obj] in
     let u = {width =  200} [@bs.obj] in
     grid##minHeight__set 300;
     grid##titleRows__set

diff --git a/jscomp/test/nested_obj_test.ml b/jscomp/test/nested_obj_test.ml
@@ -0,0 +1,13 @@
+
+
+type f_obj = < x : < y : < z : int > > > [@bs.obj]
+let f : f_obj = { x = { y = { z = 3 }}} [@bs.obj]
+
+type 'a x = {x : 'a }
+type 'a y = {y : 'a}
+type 'a z = { z : 'a}  
+let f_record   =  { x = { y = { z = 3 }}} 
+
+
+let f : f_obj = { x = { y = ({ z = 3 }[@bs.obj]) }} [@bs.obj]
+
diff --git a/jscomp/test/test.mllib b/jscomp/test/test.mllib
@@ -310,4 +310,6 @@ gpr_405_test
 
 attr_test
 
-uncurry_glob_test
+uncurry_glob_test
+
+nested_obj_test
diff --git a/lib/js/test/nested_obj_test.js b/lib/js/test/nested_obj_test.js
@@ -0,0 +1,17 @@
+// GENERATED CODE BY BUCKLESCRIPT VERSION 0.5.0 , PLEASE EDIT WITH CARE
+'use strict';
+
+
+var f = {
+  "x": {
+    "y": {
+      "z": 3
+    }
+  }
+};
+
+var f_record = /* record */[/* x : record */[/* y : record */[/* z */3]]];
+
+exports.f_record = f_record;
+exports.f        = f;
+/*  Not a pure module */