Add bs.as support

- we marked bs.as used in label description

Author: bobzhang

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_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/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

jscomp/test/record_name_test.js

@@ -0,0 +1,22 @@
+'use strict';
+
+
+function f(x) {
+  return {
+          THIS_IS_NOT_EXPRESSIBLE_IN_BUCKLE: x
+        };
+}
+
+function set(x) {
+  x.THIS_IS_NOT_EXPRESSIBLE_IN_BUCKLE = 3;
+  return (x.THIS_IS_NOT_EXPRESSIBLE_IN_BUCKLE << 1);
+}
+
+function f2(u) {
+  return u.x.x.x.y;
+}
+
+exports.f = f;
+exports.set = set;
+exports.f2 = f2;
+/* No side effect */

jscomp/test/record_name_test.ml

@@ -0,0 +1,30 @@
+
+(*
+To work around unused attribute checking
+
+- we mark it used in ppx stage
+we can not mark it in parsing since it won't
+works for reason
+*)
+type t = {
+  mutable x : int [@bs.as "THIS_IS_NOT_EXPRESSIBLE_IN_BUCKLE"]
+   (* test key word later *)
+}
+
+
+
+let f x  = { x}
+
+let set x = x.x <- 3 ; x.x * 2
+
+type x = t = private {
+  mutable x : int [@bs.as "THIS_IS_NOT_EXPRESSIBLE_IN_BUCKLE"]
+}
+
+type t0 = { x: t0 ; y : int}
+
+let f2 u = 
+match u with 
+| {x = { x = {x={y}}}}   ->     y
+
+

lib/4.06.1/bsb.ml

@@ -796,7 +796,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) -> 
@@ -1496,7 +1502,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