make type_delcaration_list overwritable, clean up type deriving mechanism

Author: bobzhang

jscomp/syntax/ast_tdcls.ml

@@ -24,7 +24,9 @@
 
 open Ast_helper
 
-
+(**
+   [newTdcls tdcls newAttrs]
+   functional update attributes of last declaration *)
 let newTdcls
     (tdcls : Parsetree.type_declaration list)
     (newAttrs : Parsetree.attributes)
@@ -47,17 +49,16 @@ let handleTdclsInSigi
     (self : Bs_ast_mapper.mapper)
     (sigi : Parsetree.signature_item)
     (tdcls : Parsetree.type_declaration list)
-    : Ast_signature.item =
+  : Ast_signature.item =
   begin match Ast_attributes.process_derive_type
                 (Ext_list.last tdcls).ptype_attributes  with
   | {bs_deriving = Some actions; explict_nonrec}, newAttrs
     ->
     let loc = sigi.psig_loc in
-    let newTdcls = newTdcls tdcls newAttrs in
-    let newSigi =
-      self.signature_item self {sigi with psig_desc = Psig_type newTdcls} in
+    let originalTdclsNewAttrs = newTdcls tdcls newAttrs in (* remove the processed attr*)
+    let newTdclsNewAttrs = self.type_declaration_list self originalTdclsNewAttrs in
     if Ast_payload.isAbstract actions then
-      let  codes = Ast_derive_abstract.handleTdclsInSig newTdcls in
+      let  codes = Ast_derive_abstract.handleTdclsInSig originalTdclsNewAttrs in
       Ast_signature.fuseAll ~loc
         (
           Sig.include_ ~loc
@@ -67,23 +68,18 @@ let handleTdclsInSigi
                      (Mod.structure ~loc [
                          { pstr_loc = loc;
                            pstr_desc =
-                             Pstr_type
-                               (match newSigi.psig_desc with
-                                | Psig_type x -> x
-                                | _ -> assert false)
+                             Pstr_type newTdclsNewAttrs
                          }] )
                      (Mty.signature ~loc [])) ) )
-          ::
-          self.signature self
-            codes
+          :: (* include module type of struct [processed_code for checking like invariance ]end *)
+          self.signature self  codes
         )
     else
       Ast_signature.fuseAll ~loc
-        (newSigi::
+        ( {psig_desc = Psig_type newTdclsNewAttrs; psig_loc = loc}::
          self.signature
            self
-           (
-             Ast_derive.gen_signature tdcls actions explict_nonrec))
+           (Ast_derive.gen_signature tdcls actions explict_nonrec))
   | {bs_deriving = None }, _  ->
     Bs_ast_mapper.default_mapper.signature_item self sigi
 
@@ -94,27 +90,27 @@ let handleTdclsInStru
     (self : Bs_ast_mapper.mapper)
     (str : Parsetree.structure_item)
     (tdcls : Parsetree.type_declaration list)
-    : Ast_structure.item =
+  : Ast_structure.item =
   begin match
       Ast_attributes.process_derive_type
         ((Ext_list.last tdcls).ptype_attributes) with
   | {bs_deriving = Some actions;
      explict_nonrec
     }, newAttrs ->
     let loc = str.pstr_loc in
-    let tdcls2 = newTdcls tdcls newAttrs in
-    let newStr =
-      self.structure_item self
-        {str with pstr_desc = Pstr_type tdcls2} in
+    let originalTdclsNewAttrs = newTdcls tdcls newAttrs in
+    let newStr : Parsetree.structure_item =
+      { pstr_desc = Pstr_type (self.type_declaration_list self originalTdclsNewAttrs);
+        pstr_loc = loc}
+    in
     if Ast_payload.isAbstract actions then
-      let codes = Ast_derive_abstract.handleTdclsInStr tdcls2 in
+      let codes = Ast_derive_abstract.handleTdclsInStr originalTdclsNewAttrs in
       (* use [tdcls2] avoid nonterminating *)
       Ast_structure.fuseAll ~loc
         (
-          Ast_structure.constraint_ ~loc
-            [newStr] []::
-          self.structure self
-            codes)
+          Ast_structure.constraint_ ~loc [newStr] []
+          :: (* [include struct end : sig end] for error checking *)
+          self.structure self codes)
     else
       Ast_structure.fuseAll ~loc
         (newStr ::

jscomp/syntax/bs_ast_mapper.ml

@@ -63,13 +63,16 @@ type mapper = {
   structure_item: mapper -> structure_item -> structure_item;
   typ: mapper -> core_type -> core_type;
   type_declaration: mapper -> type_declaration -> type_declaration;
+(* XXXX *)
+  type_declaration_list : mapper -> type_declaration list -> type_declaration list;
+(* XXXX *)
   type_extension: mapper -> type_extension -> type_extension;
   type_kind: mapper -> type_kind -> type_kind;
   value_binding: mapper -> value_binding -> value_binding;
 (* XXXX *)
-  value_bindings_rec : mapper -> value_binding list -> value_binding list; 
-  value_bindings : mapper -> value_binding list -> value_binding list; 
-(* XXXXX *)  
+  value_bindings_rec : mapper -> value_binding list -> value_binding list;
+  value_bindings : mapper -> value_binding list -> value_binding list;
+(* XXXXX *)
   value_description: mapper -> value_description -> value_description;
   with_constraint: mapper -> with_constraint -> with_constraint;
 }
@@ -133,7 +136,9 @@ module T = struct
       ?manifest:(map_opt (sub.typ sub) ptype_manifest)
       ~loc:(sub.location sub ptype_loc)
       ~attrs:(sub.attributes sub ptype_attributes)
-
+(* XXXX *)
+  let map_type_declaration_list sub l = List.map  (sub.type_declaration sub) l
+(* XXXX *)
   let map_type_kind sub = function
     | Ptype_abstract -> Ptype_abstract
     | Ptype_variant l ->
@@ -242,7 +247,7 @@ module MT = struct
     let loc = sub.location sub loc in
     match desc with
     | Psig_value vd -> value ~loc (sub.value_description sub vd)
-    | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+    | Psig_type l -> type_ ~loc (sub.type_declaration_list sub l)
     | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
     | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
     | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
@@ -288,15 +293,15 @@ module M = struct
     match desc with
     | Pstr_eval (x, attrs) ->
         eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
-    | Pstr_value (r, vbs) -> 
-(* XXX *)    
+    | Pstr_value (r, vbs) ->
+(* XXX *)
 (* value ~loc r (List.map (sub.value_binding sub) vbs) *)
-      value ~loc r 
+      value ~loc r
       ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
        sub vbs)
-(* XXX *)          
+(* XXX *)
     | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
-    | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+    | Pstr_type l -> type_ ~loc (sub.type_declaration_list sub l)
     | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
     | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
     | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
@@ -323,16 +328,16 @@ module E = struct
     | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
     | Pexp_constant x -> constant ~loc ~attrs x
     | Pexp_let (r, vbs, e) ->
-(* XXXX *)    
+(* XXXX *)
         (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
           (sub.expr sub e) *)
-        let_ ~loc ~attrs r 
+        let_ ~loc ~attrs r
         (
-          (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)  
+          (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
           sub vbs
-        ) 
+        )
         (sub.expr sub e)
-(* XXXX *)              
+(* XXXX *)
     | Pexp_fun (lab, def, p, e) ->
         fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
           (sub.expr sub e)
@@ -445,14 +450,14 @@ module CE = struct
         apply ~loc ~attrs (sub.class_expr sub ce)
           (List.map (map_snd (sub.expr sub)) l)
     | Pcl_let (r, vbs, ce) ->
-(* XXXX *)    
+(* XXXX *)
         (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
           (sub.class_expr sub ce) *)
-          let_ ~loc ~attrs r 
+          let_ ~loc ~attrs r
           ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
             sub vbs)
           (sub.class_expr sub ce)
-(* XXXX *)              
+(* XXXX *)
     | Pcl_constraint (ce, ct) ->
         constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
     | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
@@ -519,6 +524,7 @@ let default_mapper =
     class_description =
       (fun this -> CE.class_infos this (this.class_type this));
     type_declaration = T.map_type_declaration;
+    type_declaration_list = T.map_type_declaration_list;
     type_kind = T.map_type_kind;
     typ = T.map;
     type_extension = T.map_type_extension;
@@ -586,13 +592,13 @@ let default_mapper =
            ~attrs:(this.attributes this pincl_attributes)
       );
 
-    value_bindings = (fun this vbs -> 
-      match vbs with 
+    value_bindings = (fun this vbs ->
+      match vbs with
       | [vb] -> [ this.value_binding this vb ]
       | _ -> List.map (this.value_binding this) vbs
     );
-    value_bindings_rec = (fun this vbs -> 
-      match vbs with 
+    value_bindings_rec = (fun this vbs ->
+      match vbs with
       | [vb] -> [ this.value_binding this vb ]
       | _ -> List.map (this.value_binding this) vbs
     );
@@ -649,4 +655,4 @@ let default_mapper =
          | PTyp x -> PTyp (this.typ this x)
          | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
       );
-  }
+  }

jscomp/syntax/bs_ast_mapper.mli

@@ -46,9 +46,9 @@ let () =
   *)
 
   open Parsetree
-  
+
   (** {2 A generic Parsetree mapper} *)
-  
+
   type mapper = {
     attribute: mapper -> attribute -> attribute;
     attributes: mapper -> attribute list -> attribute list;
@@ -89,21 +89,23 @@ let () =
     structure_item: mapper -> structure_item -> structure_item;
     typ: mapper -> core_type -> core_type;
     type_declaration: mapper -> type_declaration -> type_declaration;
+(* XXXXX *)
+    type_declaration_list: mapper -> type_declaration list -> type_declaration list;
+(* XXXXX *)
     type_extension: mapper -> type_extension -> type_extension;
     type_kind: mapper -> type_kind -> type_kind;
     value_binding: mapper -> value_binding -> value_binding;
-(* XXXXX *)    
+(* XXXXX *)
     value_bindings_rec: mapper -> value_binding list -> value_binding list;
     value_bindings: mapper -> value_binding list -> value_binding list;
-(* XXXXX *)        
+(* XXXXX *)
     value_description: mapper -> value_description -> value_description;
     with_constraint: mapper -> with_constraint -> with_constraint;
   }
   (** A mapper record implements one "method" per syntactic category,
       using an open recursion style: each method takes as its first
       argument the mapper to be applied to children in the syntax
       tree. *)
-  
+
   val default_mapper: mapper
   (** A default mapper, which implements a "deep identity" mapping. *)
-  

jscomp/test/.depend

@@ -307,6 +307,7 @@ gpr_2474.cmj :
 gpr_2487.cmj : ../others/belt.cmj
 gpr_2503_test.cmj : mt.cmj ../runtime/js.cmj
 gpr_2608_test.cmj : mt.cmj ../stdlib/list.cmj
+gpr_2614_test.cmj :
 gpr_2633_test.cmj :
 gpr_2642_test.cmj :
 gpr_2652_test.cmj : ../others/node.cmj ../stdlib/buffer.cmj

jscomp/test/Makefile

@@ -248,6 +248,7 @@ OTHERS := test_literals a test_ari test_export2 test_internalOO test_obj_simple_
 	gpr_2413_test\
 	gpr_2642_test\
 	gpr_2652_test\
+	gpr_2614_test\
 # bs_uncurry_test
 # needs Lam to get rid of Uncurry arity first
 # simple_derive_test

jscomp/test/bs_array_test.js

@@ -450,14 +450,14 @@ eq("File \"bs_array_test.ml\", line 131, characters 5-12", Belt_Array.mapWithInd
       5
     ]);
 
-eq("File \"bs_array_test.ml\", line 132, characters 5-12", Belt_List.ofArray(/* array */[]), /* [] */0);
+eq("File \"bs_array_test.ml\", line 132, characters 5-12", Belt_List.fromArray(/* array */[]), /* [] */0);
 
-eq("File \"bs_array_test.ml\", line 133, characters 5-12", Belt_List.ofArray(/* int array */[1]), /* :: */[
+eq("File \"bs_array_test.ml\", line 133, characters 5-12", Belt_List.fromArray(/* int array */[1]), /* :: */[
       1,
       /* [] */0
     ]);
 
-eq("File \"bs_array_test.ml\", line 134, characters 5-12", Belt_List.ofArray(/* int array */[
+eq("File \"bs_array_test.ml\", line 134, characters 5-12", Belt_List.fromArray(/* int array */[
           1,
           2,
           3