address rescript-lang#3204

Author: bobzhang

jscomp/all.depend

@@ -229,9 +229,10 @@ syntax/external_process.cmx : common/lam_methname.cmx \
     syntax/ast_attributes.cmx syntax/external_process.cmi
 syntax/ast_derive_abstract.cmx : syntax/external_process.cmx \
     syntax/external_ffi_types.cmx syntax/external_arg_spec.cmx \
-    ext/ext_list.cmx syntax/ast_literal.cmx syntax/ast_derive_util.cmx \
-    syntax/ast_core_type.cmx syntax/ast_compatible.cmx \
-    syntax/ast_attributes.cmx syntax/ast_derive_abstract.cmi
+    ext/ext_list.cmx syntax/ast_payload.cmx syntax/ast_literal.cmx \
+    syntax/ast_derive_util.cmx syntax/ast_core_type.cmx \
+    syntax/ast_compatible.cmx syntax/ast_attributes.cmx \
+    syntax/ast_derive_abstract.cmi
 syntax/ast_derive_dyn.cmx : ext/ext_list.cmx syntax/bs_syntaxerr.cmx \
     syntax/ast_structure.cmx syntax/ast_derive_util.cmx syntax/ast_derive.cmx \
     syntax/ast_compatible.cmx syntax/ast_attributes.cmx \
@@ -251,7 +252,7 @@ syntax/ast_util.cmx : ext/literals.cmx syntax/external_process.cmx \
     syntax/ast_core_type.cmx syntax/ast_compatible.cmx syntax/ast_comb.cmx \
     syntax/ast_attributes.cmx syntax/ast_util.cmi
 syntax/ast_tdcls.cmx : ext/ext_list.cmx syntax/bs_ast_mapper.cmx \
-    syntax/ast_structure.cmx syntax/ast_signature.cmx syntax/ast_payload.cmx \
+    syntax/ast_structure.cmx syntax/ast_signature.cmx \
     syntax/ast_derive_abstract.cmx syntax/ast_derive.cmx \
     syntax/ast_compatible.cmx syntax/ast_attributes.cmx syntax/ast_tdcls.cmi
 syntax/ast_primitive.cmx : syntax/external_process.cmx \
@@ -309,7 +310,7 @@ syntax/ast_polyvar.cmi : syntax/external_arg_spec.cmi
 syntax/external_ffi_types.cmi : syntax/external_arg_spec.cmi
 syntax/external_process.cmi : common/bs_loc.cmi syntax/ast_core_type.cmi \
     syntax/ast_attributes.cmi
-syntax/ast_derive_abstract.cmi :
+syntax/ast_derive_abstract.cmi : syntax/ast_payload.cmi
 syntax/ast_derive_dyn.cmi :
 syntax/ast_derive_projector.cmi :
 syntax/ast_derive_js_mapper.cmi :

jscomp/syntax/ast_derive_abstract.ml

@@ -28,10 +28,20 @@ module U = Ast_derive_util
 open Ast_helper
 type tdcls = Parsetree.type_declaration list
 
+type abstractKind = 
+  | Not_abstract
+  | Light_abstract
+  | Complex_abstract 
+
 let  isAbstract (xs :Ast_payload.action list) = 
   match xs with 
-  | [{loc; txt = "abstract"}, None]  -> 
-    true 
+  | [{loc; txt = "abstract"}, 
+    (None 
+    )]  -> 
+    Complex_abstract
+  | [{loc; txt = "abstract"}, 
+    Some {pexp_desc = Pexp_ident {txt = Lident "light"}}  
+    ] -> Light_abstract
   | [{loc; txt = "abstract"}, Some _ ]
     -> 
       Location.raise_errorf ~loc "invalid config for abstract"
@@ -43,7 +53,7 @@ let  isAbstract (xs :Ast_payload.action list) =
           "bs.deriving abstract does not work with any other deriving"
       | _ -> ()
     ) ;
-    false
+    Not_abstract
 (* let handle_config (config : Parsetree.expression option) =
   match config with
   | Some config ->
@@ -69,7 +79,11 @@ let deprecated name =
     ("use " ^ name ^ "Get instead")
 
 
-let handleTdcl (tdcl : Parsetree.type_declaration) =
+let handleTdcl 
+  light
+  (tdcl : Parsetree.type_declaration) 
+  : Parsetree.type_declaration * Parsetree.value_description list 
+  =
   let core_type = U.core_type_of_type_declaration tdcl in
   let loc = tdcl.ptype_loc in
   let type_name = tdcl.ptype_name.txt in
@@ -123,24 +137,27 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
 #end              
 
                 maker,
-              let aux b pld_name = 
+              let aux light deprec pld_name : Parsetree.value_description = 
                 (Val.mk ~loc:pld_loc
-                 (if b then pld_name else 
+                 (if light then pld_name else 
                   {pld_name with txt = pld_name.txt ^ "Get"})
-                ~attrs:(if b then deprecated (pld_name.Asttypes.txt) :: get_optional_attrs  
+                ~attrs:(if deprec then deprecated (pld_name.Asttypes.txt) :: get_optional_attrs  
                         else get_optional_attrs) ~prim
                 (Ast_compatible.arrow ~loc  core_type optional_type)
                 ) in 
-               aux true pld_name :: aux false pld_name  :: acc )
+                if not light then 
+                  aux true true pld_name :: aux false false pld_name  :: acc
+                else  aux true false pld_name :: acc                   
+              )
             else
               Ast_compatible.label_arrow ~loc:pld_loc label_name pld_type maker,
               (
-                let aux b pld_name = 
-                Val.mk ~loc:pld_loc 
-                  (if b then pld_name else 
-                    {pld_name with txt = pld_name.txt ^ "Get"}
-                  ) ~attrs:(if b then deprecated pld_name.Asttypes.txt :: get_attrs else get_attrs)
-              ~prim:(
+                let aux light deprec pld_name = 
+                  Val.mk ~loc:pld_loc 
+                    (if light then pld_name else 
+                       {pld_name with txt = pld_name.txt ^ "Get"}
+                    ) ~attrs:(if deprec then deprecated pld_name.Asttypes.txt :: get_attrs else get_attrs)
+                    ~prim:(
                 ["" ; (* Not needed actually*)
                 External_ffi_types.to_string 
                 (Ffi_bs (
@@ -150,7 +167,10 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
                   ))] )
                (Ast_compatible.arrow ~loc  core_type pld_type)
                in 
-               aux true pld_name ::aux false pld_name :: acc )
+               if not light then 
+                aux true true pld_name ::aux false false pld_name :: acc 
+               else aux true false pld_name :: acc 
+              )
           in
           let is_current_field_mutable = pld_mutable = Mutable in
           let acc =
@@ -194,21 +214,21 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
     (* U.notApplicable tdcl.ptype_loc derivingName;  *)
     tdcl, []
 
-let handleTdclsInStr tdcls =
+let handleTdclsInStr ~light tdcls =
   let tdcls, code =
     Ext_list.fold_right tdcls ([],[]) (fun tdcl (tdcls, sts)  ->
-        match handleTdcl tdcl with
+        match handleTdcl light tdcl with
           ntdcl, value_descriptions ->
           ntdcl::tdcls,
           Ext_list.map_append value_descriptions sts (fun x -> Str.primitive x) 
       ) in
 Ast_compatible.rec_type_str tdcls :: code
 (* still need perform transformation for non-abstract type*)
 
-let handleTdclsInSig tdcls =
+let handleTdclsInSig ~light tdcls =
   let tdcls, code =
     Ext_list.fold_right tdcls ([],[]) (fun tdcl (tdcls, sts)  ->
-        match handleTdcl tdcl with
+        match handleTdcl light tdcl with
           ntdcl, value_descriptions ->
           ntdcl::tdcls,
           Ext_list.map_append value_descriptions sts (fun x -> Sig.value x) 

jscomp/syntax/ast_derive_abstract.mli

@@ -22,17 +22,23 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
- 
+type abstractKind = 
+  | Not_abstract
+  | Light_abstract
+  | Complex_abstract 
+
 val isAbstract : 
-  Ast_payload.action list -> bool
+  Ast_payload.action list -> abstractKind
 (** if only [abstract] happens  [true]
     if [abstract] does not appear [false]
     if [abstract] happens with other, raise exception
 *)  
 
 
 val handleTdclsInStr : 
+  light:bool -> 
   Parsetree.type_declaration list -> Parsetree.structure
 
 val handleTdclsInSig:  
+  light:bool ->
   Parsetree.type_declaration list -> Parsetree.signature

jscomp/syntax/ast_tdcls.ml

@@ -57,8 +57,9 @@ let handleTdclsInSigi
     let loc = sigi.psig_loc in
     let originalTdclsNewAttrs = newTdcls tdcls newAttrs in (* remove the processed attr*)
     let newTdclsNewAttrs = self.type_declaration_list self originalTdclsNewAttrs in
-    if Ast_derive_abstract.isAbstract actions then
-      let  codes = Ast_derive_abstract.handleTdclsInSig originalTdclsNewAttrs in
+    let kind = Ast_derive_abstract.isAbstract actions in
+    if kind <> Not_abstract then
+      let  codes = Ast_derive_abstract.handleTdclsInSig ~light:(kind = Light_abstract) originalTdclsNewAttrs in
       Ast_signature.fuseAll ~loc
         (
           Sig.include_ ~loc
@@ -102,8 +103,10 @@ let handleTdclsInStru
     let newStr : Parsetree.structure_item =
       Ast_compatible.rec_type_str ~loc (self.type_declaration_list self originalTdclsNewAttrs)
     in
-    if Ast_derive_abstract.isAbstract actions then
-      let codes = Ast_derive_abstract.handleTdclsInStr originalTdclsNewAttrs in
+    let kind = Ast_derive_abstract.isAbstract actions in 
+    if kind <> Not_abstract then
+      let codes = 
+          Ast_derive_abstract.handleTdclsInStr ~light:(kind = Light_abstract) originalTdclsNewAttrs in
       (* use [tdcls2] avoid nonterminating *)
       Ast_structure.fuseAll ~loc
         (

jscomp/test/bs_abstract_test.js

@@ -45,11 +45,16 @@ function uff3(f) {
   }
 }
 
+function fx(v) {
+  return v.x;
+}
+
 exports.f = f;
 exports.uf = uf;
 exports.uf1 = uf1;
 exports.uf2 = uf2;
 exports.uff = uff;
 exports.uff2 = uff2;
 exports.uff3 = uff3;
+exports.fx = fx;
 /*  Not a pure module */

jscomp/test/bs_abstract_test.ml

@@ -52,4 +52,16 @@ let uff2 f =
 let uff3 f =   
   match f |. yyyy2Get with 
   | None -> 0
-  | Some x  -> x 0 
+  | Some x  -> x 0 
+
+
+
+type u3 = {
+  x : int; 
+  yyyy : (int -> int [@bs]);
+  yyyy1 : (int -> int -> int  [@bs]);
+  yyyy2 : int -> int  [@bs.optional]
+} [@@bs.deriving { abstract = light} ]
+
+
+let fx v = v |. x 

jscomp/test/bs_abstract_test.mli

@@ -24,4 +24,7 @@ type u1
   val uff : u1 -> int 
   val uff2 : u1 -> int 
 
-  val uff3 : u1 -> int 
+  val uff3 : u1 -> int 
+
+type u3   
+val fx : u3 -> int