record renaming support fix #3979

jscomp/common/bs_version.ml

@@ -22,7 +22,7 @@
  * You should have received a copy of the GNU Lesser General Public License
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)    
-let version = "6.3.0-dev.1"
+let version = "7.0.0-dev.2"
 let header = 
    "// Generated by BUCKLESCRIPT, PLEASE EDIT WITH CARE"  
 let package_name = "bs-platform"   

jscomp/core/bs_conditional_initial.ml

@@ -37,7 +37,10 @@ let setup_env () =
   Clflags.binary_annotations := true; 
   (* Turn on [-no-alias-deps] by default -- double check *)
   Oprint.out_ident := Outcome_printer_ns.out_ident;
-
+  Builtin_attributes.check_bs_attributes_inclusion := Record_attributes_check.check_bs_attributes_inclusion;
+  Lambda.fld_record := Record_attributes_check.fld_record;
+  Lambda.fld_record_set := Record_attributes_check.fld_record_set;
+  Lambda.blk_record := Record_attributes_check.blk_record;
 #if undefined BS_RELEASE_BUILD then
     Printexc.record_backtrace true;
     (match Ext_sys.getenv_opt "BS_DEBUG_FILE" with 

jscomp/core/js_dump.ml

@@ -811,8 +811,9 @@ and expression_desc cxt ~(level:int) f x : cxt  =
         (Ext_list.map_combine fields el Ext_ident.convert)))
   | Caml_block(el,_, _, Blk_record fields) ->        
       expression_desc cxt ~level f (Object (
-        (Ext_list.map_combine (Array.to_list fields) el Ext_ident.convert)))      
-        (*FIXME: avoid allocaton *)
+        (List.combine (Array.to_list fields) el )))      
+        (* name convention of Record is slight different from modules 
+        *)
   | Caml_block( el, mutable_flag, tag, tag_info)
     ->
     (* Note that, if we ignore more than tag [0] we loose some information

jscomp/core/js_exp_make.ml

@@ -397,7 +397,7 @@ let array_index_by_int ?comment (e : t)  (pos : int32) : t =
   | _ -> { expression_desc = Array_index (e, int ?comment pos); comment = None} 
 
 let record_access (e : t) (name : string) (pos : int32) = 
-  let name = Ext_ident.convert name in 
+  (* let name = Ext_ident.convert name in  *)
   match e.expression_desc with
   | Array (l,_) (* Float i -- should not appear here *)
   | Caml_block (l,_, _, _) when no_side_effect e

jscomp/core/js_of_lam_block.ml

@@ -60,7 +60,7 @@ let field (field_info : Lam_compat.field_dbg_info) e i =
     -> 
     E.array_index_by_int  ~comment e i 
 #end
-  | Fld_record name
+  | Fld_record {name}
     -> E.record_access e name i
   | Fld_module name
     -> E.module_access e name i

jscomp/core/lam_compat.ml

@@ -184,7 +184,7 @@ type meth_kind = Lambda.meth_kind
 
 type field_dbg_info = Lambda.field_dbg_info =
   | Fld_na
-  | Fld_record of string
+  | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
   | Fld_module of string 
 #if OCAML_VERSION =~ ">4.03.0"  then 
   | Fld_record_inline of string 
@@ -195,7 +195,7 @@ let str_of_field_info (x : field_dbg_info) : string option =
   match x with 
   | Fld_na 
   | Fld_tuple -> None 
-  | Fld_record s 
+  | Fld_record {name = s} 
   | Fld_module s 
   | Fld_record_inline s 
   | Fld_record_extension s 

jscomp/core/lam_compat.mli

@@ -85,7 +85,7 @@ type meth_kind = Lambda.meth_kind
 
 type field_dbg_info = Lambda.field_dbg_info =
   | Fld_na
-  | Fld_record of string
+  | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
   | Fld_module of string 
 #if OCAML_VERSION =~ ">4.03.0"  then 
   | Fld_record_inline of string 

jscomp/core/record_attributes_check.ml

@@ -0,0 +1,61 @@
+(* Copyright (C) 2019- Authors of BuckleScript
+ * 
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ * 
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+type label = Types.label_description
+
+let fn = (fun (attr : Parsetree.attribute) -> 
+match attr with 
+| {txt = "bs.as"}, PStr 
+  [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string(s,_))},_ )}] -> 
+    (* Bs_ast_invariant.mark_used_bs_attribute attr; *)
+    Some s 
+| _ -> None
+)
+
+let fld_record (lbl : label) = 
+  Lambda.Fld_record
+    {name = Ext_list.find_def lbl.lbl_attributes fn lbl.lbl_name; mutable_flag = lbl.Types.lbl_mut}
+
+let fld_record_set (lbl : label) = 
+  Lambda.Fld_record_set 
+    (Ext_list.find_def lbl.lbl_attributes fn lbl.lbl_name)
+
+let blk_record  fields = 
+  let all_labels_info = 
+    Ext_array.map fields   
+      (fun ((lbl : label),_) -> 
+         Ext_list.find_def lbl.Types.lbl_attributes fn lbl.lbl_name) in  
+  Lambda.Blk_record all_labels_info
+
+let check_bs_attributes_inclusion
+  (attrs1 : Parsetree.attributes)
+  (attrs2 : Parsetree.attributes)
+  lbl_name =   
+  let a = Ext_list.find_def attrs1 fn lbl_name in 
+  let b = Ext_list.find_def attrs2 fn lbl_name in 
+  if a = b then None 
+  else Some (a,b)
+
+
+

jscomp/ext/ext_list.ml

@@ -583,7 +583,13 @@ let rec find_opt xs p =
     | Some _ as v  ->  v
     | None -> find_opt l p
 
-
+let rec find_def xs p def =
+  match xs with 
+  | [] -> def
+  | x::l -> 
+    match p x with 
+    | Some v -> v 
+    | None -> find_def l p def   
 
 let rec split_map l f = 
   match l with

jscomp/ext/ext_list.mli

@@ -259,7 +259,13 @@ val find_opt :
   ('a -> 'b option) -> 
   'b option 
 
+val find_def : 
+    'a list -> 
+    ('a -> 'b option) ->
+    'b ->
+    'b 
 
+
 val rev_iter : 
   'a list -> 
   ('a -> unit) -> 

jscomp/syntax/bs_ast_invariant.ml

@@ -117,6 +117,16 @@ let emit_external_warnings : iterator=
 #end
         | _ -> default_iterator.expr self a 
       );
+    label_declaration = (fun self lbl ->
+
+      Ext_list.iter lbl.pld_attributes 
+        (fun attr -> 
+          match attr with 
+          | {txt = "bs.as"}, _ -> mark_used_bs_attribute attr
+          | _ -> ()
+          );
+      default_iterator.label_declaration self lbl      
+    );  
     value_description =
       (fun self v -> 
          match v with 

jscomp/test/build.ninja

@@ -496,6 +496,7 @@ build test/rec_module_test.cmi test/rec_module_test.cmj : cc test/rec_module_tes
 build test/rec_value_test.cmi test/rec_value_test.cmj : cc test/rec_value_test.ml | test/mt.cmj $stdlib
 build test/record_debug_test.cmi test/record_debug_test.cmj : cc test/record_debug_test.ml | $stdlib
 build test/record_extension_test.cmi test/record_extension_test.cmj : cc test/record_extension_test.ml | test/mt.cmj $stdlib
+build test/record_name_test.cmi test/record_name_test.cmj : cc test/record_name_test.ml | $stdlib
 build test/record_with_test.cmi test/record_with_test.cmj : cc test/record_with_test.ml | test/mt.cmj $stdlib
 build test/recursive_module.cmi test/recursive_module.cmj : cc test/recursive_module.ml | test/mt.cmj $stdlib
 build test/recursive_module_test.cmi test/recursive_module_test.cmj : cc test/recursive_module_test.ml | test/mt.cmj $stdlib