Merge pull request #3998 from BuckleScript/p_is_int_test

add tests for Pisint, fix #3996

Author: bobzhang

jscomp/core/js_block_runtime.ml

@@ -32,7 +32,7 @@ let tag_is_zero (tag : J.expression) =
   (tag : J.expression)
   (tag_info : J.tag_info) = 
   match tag_info with 
-  | Blk_variant _     
+  | Blk_poly_var _     
   | Blk_constructor _   -> true
 #if OCAML_VERSION =~ ">4.03.0" then
   | Blk_record_inlined _ -> true  
@@ -52,7 +52,7 @@ let tag_is_zero (tag : J.expression) =
 
 let needBlockRuntime (tag : J.expression) (tag_info : J.tag_info) = 
   match  tag_info with 
-  | Blk_variant _ 
+  | Blk_poly_var _ 
   | Blk_module _
   | Blk_module_export
   | Blk_record _  

jscomp/core/js_dump.ml

@@ -851,7 +851,7 @@ and expression_desc cxt ~(level:int) f x : cxt  =
               TODO: we still need clean up local module compilation 
               to make it more obvious
             *)
-        | Blk_variant name ->  
+        | Blk_poly_var name ->  
           dbg_poly_var f;
           P.paren_group f 1 (fun _ -> arguments cxt f [ 
               E.str name;

jscomp/core/js_exp_make.ml

@@ -205,7 +205,7 @@ let make_block ?comment
     | Blk_extension 
     | Blk_class 
     | Blk_constructor _ 
-    | Blk_variant _ 
+    | Blk_poly_var _ 
     | Blk_na _
       ->  es
   in
@@ -296,7 +296,7 @@ let dummy_obj ?comment (info : Lam_tag_info.t)  : t =
     {comment ; expression_desc = Object ([])}
   | Blk_constructor _ 
   | Blk_tuple | Blk_array
-  | Blk_variant _ | Blk_extension_slot 
+  | Blk_poly_var _ | Blk_extension_slot 
   | Blk_extension | Blk_na _ 
   | Blk_record_inlined _ 
   | Blk_record_ext _ 

jscomp/core/js_of_lam_block.ml

@@ -56,12 +56,13 @@ let field (field_info : Lam_compat.field_dbg_info) e i =
   | Fld_poly_var_content 
   | Fld_record_inline _
   | Fld_record_extension _
+  | Fld_extension_slot
     -> 
     E.array_index_by_int  
       ?comment:(Lam_compat.str_of_field_info field_info) e i 
   | Fld_record {name}
     -> E.record_access e name i
-  | Fld_module name
+  | Fld_module {name}
     -> E.module_access e name i
 let field_by_exp e i = 
   E.array_index e i 

jscomp/core/lam.ml

@@ -652,15 +652,15 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc  : t =
       let rec aux fields args (var : Ident.t) i =
         match fields, args with 
         | [], [] -> true 
-        | f :: fields, Lprim {primitive = Pfield (pos, Fld_module f1); args = [Lglobal_module v1 | Lvar v1]} :: args 
+        | f :: fields, Lprim {primitive = Pfield (pos, Fld_module {name = f1}); args = [Lglobal_module v1 | Lvar v1]} :: args 
           -> 
             pos = i && 
             f = f1 &&
             Ident.same var v1 && aux fields args var (i + 1)
         | _, _ -> false in   
       begin match fields, args with   
       | field1 :: rest, 
-          Lprim{primitive = Pfield (pos, Fld_module f1); args = [Lglobal_module v1 | Lvar v1 as lam]} :: args1
+          Lprim{primitive = Pfield (pos, Fld_module {name = f1}); args = [Lglobal_module v1 | Lvar v1 as lam]} :: args1
           ->
           if pos = 0 && field1 = f1 && aux rest args1 v1 1 then 
             lam

jscomp/core/lam_arity_analysis.ml

@@ -44,14 +44,14 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) :  Lam_arity.t =
   | Lvar v -> arity_of_var meta v 
   | Lconst _ -> Lam_arity.non_function_arity_info
   | Llet(_,_,_, l ) -> get_arity meta l 
-  | Lprim {primitive = Pfield (_, Fld_module fld_name); 
+  | Lprim {primitive = Pfield (_, Fld_module {name = fld_name}); 
            args =  [ Lglobal_module id  ]; _} -> 
     begin match (Lam_compile_env.query_external_id_info id fld_name).arity with 
       | Single x -> x 
       | Submodule _ -> Lam_arity.na
     end
   | Lprim {primitive = Pfield (m,_); 
-           args =  [ Lprim{primitive = Pfield(n,Fld_module fld_name); 
+           args =  [ Lprim{primitive = Pfield(n,Fld_module {name = fld_name}); 
                            args = [ Lglobal_module id]}  ]
           ; _} ->
     begin match (Lam_compile_env.query_external_id_info id fld_name ).arity with 

jscomp/core/lam_compat.ml

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

jscomp/core/lam_compat.mli

@@ -86,15 +86,15 @@ type meth_kind = Lambda.meth_kind
 type field_dbg_info = Lambda.field_dbg_info =
   | Fld_na
   | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
-  | Fld_module of string 
+  | Fld_module of {name : string }
 #if OCAML_VERSION =~ ">4.03.0"  then 
-  | Fld_record_inline of string 
-  | Fld_record_extension of string 
+  | Fld_record_inline of {name : string}
+  | Fld_record_extension of {name : string}
 #end  
   | Fld_tuple
   | Fld_poly_var_tag
   | Fld_poly_var_content
-
+  | Fld_extension_slot
 
 val str_of_field_info : 
   field_dbg_info -> 

jscomp/core/lam_compile.ml

@@ -1338,7 +1338,7 @@ and compile_apply
          this information, we should fix [get_exp_with_args]
       *)
       begin match fld_info with 
-        | Fld_module fld_name -> 
+        | Fld_module {name = fld_name} -> 
           compile_external_field_apply  args id fld_name  lambda_cxt
         | _ -> assert false
       end     
@@ -1407,7 +1407,7 @@ and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t
     | {primitive = Pfield (_, fld_info); args = [ Lglobal_module id ]; _}
       -> (* should be before Lglobal_global *)
       begin match fld_info with 
-      | Fld_module field -> 
+      | Fld_module {name = field} -> 
          compile_external_field lambda_cxt id field 
       | _ -> assert false  
       end

jscomp/core/lam_compile_util.ml

@@ -45,7 +45,7 @@ let comment_of_tag_info  (x : Lam_tag_info.t) =
   | Blk_constructor (n, _) -> Some n 
   | Blk_tuple -> Some "tuple"
   | Blk_class -> Some "class"
-  | Blk_variant x -> Some ("`" ^  x)
+  | Blk_poly_var x -> Some ("`" ^  x)
   | Blk_record _ -> None
 #if OCAML_VERSION =~ ">4.03.0" then
   | Blk_record_inlined (_,ctor,_) -> Some ctor

jscomp/core/lam_constant_convert.ml

@@ -68,8 +68,8 @@ let rec convert_constant ( const : Lambda.structured_constant) : Lam_constant.t
     | Blk_array -> 
       let t : Lam_tag_info.t = Blk_array in 
       Const_block (i,t, Ext_list.map xs convert_constant )
-    | Blk_variant s -> 
-      let t : Lam_tag_info.t = Blk_variant s in 
+    | Blk_poly_var s -> 
+      let t : Lam_tag_info.t = Blk_poly_var s in 
       Const_block (i,t, Ext_list.map xs convert_constant )      
     | Blk_record s -> 
       let t : Lam_tag_info.t = Blk_record s in 

jscomp/core/lam_convert.ml

@@ -234,8 +234,8 @@ let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
     | Blk_array -> 
       let info : Lam_tag_info.t = Blk_array in
       prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
-    | Blk_variant s -> 
-      let info : Lam_tag_info.t = Blk_variant s in
+    | Blk_poly_var s -> 
+      let info : Lam_tag_info.t = Blk_poly_var s in
       prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
     | Blk_record s -> 
       let info : Lam_tag_info.t = Blk_record s in

jscomp/core/lam_pass_remove_alias.ml

@@ -115,7 +115,7 @@ let simplify_alias
       return [0, $$let[5],... $$let[16]]}
     *)      
     | Lapply{fn = 
-               Lprim {primitive = Pfield (index, Fld_module fld_name) ;
+               Lprim {primitive = Pfield (index, Fld_module {name = fld_name}) ;
                       args = [ Lglobal_module ident ];
                       _} as l1;
              args; loc ; status} ->

jscomp/core/lam_print.ml

@@ -438,7 +438,7 @@ let lambda ppf v  =
         "@[<2>(let@ (@[<hv 1>%a@]" bindings (List.rev args);
       fprintf ppf ")@ %a)@]"  lam body
     | Lprim { 
-        primitive = Pfield (n,Fld_module s); 
+        primitive = Pfield (n,Fld_module {name = s}); 
         args = [ Lglobal_module id ]
         ;  _} ->
       fprintf ppf "%s.%s/%d" id.name s n

jscomp/core/lam_tag_info.ml

@@ -31,7 +31,7 @@ type t =
   | Blk_constructor of string * int
   | Blk_tuple
   | Blk_array
-  | Blk_variant of string 
+  | Blk_poly_var of string 
   | Blk_record of string array 
   | Blk_module of string list
   | Blk_extension_slot

jscomp/core/record_attributes_check.ml

@@ -73,14 +73,17 @@ let rec check_duplicated_labels_aux
     | {pld_name= ({txt} as pld_name); pld_attributes}::rest ->
         if String_set.mem coll txt then Some            pld_name
         else 
-          let coll = String_set.add coll txt in
+          let coll_with_lbl = String_set.add coll txt in
           match Ext_list.find_opt pld_attributes find_name_with_loc with 
-          | None -> check_duplicated_labels_aux rest coll
+          | None -> check_duplicated_labels_aux rest coll_with_lbl
           | Some ({txt = s;} as l) -> 
-            if String_set.mem coll s then  
+            if String_set.mem coll s  
+              (*use coll to make check a bit looser
+                allow cases like [ x : int [@bs.as "x"]]
+               *) then  
               Some l
             else 
-              check_duplicated_labels_aux rest (String_set.add coll s)
+              check_duplicated_labels_aux rest (String_set.add coll_with_lbl s)
 
 let check_duplicated_labels lbls = 
     check_duplicated_labels_aux lbls String_set.empty             

jscomp/test/exception_rebind_test.js

@@ -13,9 +13,12 @@ var B = {
   F: E
 };
 
+var A0 = Caml_exceptions.create("Exception_rebind_test.A0");
+
 var H = Exception_def.A;
 
 exports.A = A;
 exports.B = B;
 exports.H = H;
+exports.A0 = A0;
 /* Exception_def Not a pure module */

jscomp/test/exception_rebind_test.ml

@@ -9,3 +9,11 @@ module B = struct
 end
 
 exception H = Exception_def.A
+
+
+type u = exn 
+
+type exn += A0 of int 
+#if 0 then
+type u += A1 of int (*Type definition u is not extensible*)
+#end

jscomp/test/poly_variant_test.js

@@ -120,6 +120,21 @@ function test(readline, x) {
   return /* () */0;
 }
 
+function p_is_int_test(x) {
+  if (typeof x === "number") {
+    return 2;
+  } else {
+    return 3;
+  }
+}
+
+eq("File \"poly_variant_test.ml\", line 142, characters 5-12", 2, 2);
+
+eq("File \"poly_variant_test.ml\", line 143, characters 5-12", 3, p_is_int_test(/* `b */[
+          98,
+          2
+        ]));
+
 Mt.from_pair_suites("Poly_variant_test", suites.contents);
 
 function on2(prim, prim$1) {
@@ -144,4 +159,5 @@ exports.test = test;
 exports.on2 = on2;
 exports.read = read;
 exports.readN = readN;
+exports.p_is_int_test = p_is_int_test;
 /*  Not a pure module */

jscomp/test/poly_variant_test.ml

@@ -130,4 +130,16 @@ let register readline =
 let test readline x  = 
   on readline x 
 
+
+let p_is_int_test x = 
+  match x with 
+  | `a -> 2 
+  | `b _ -> 3 
+
+let u = `b 2  
+
+let () = 
+  eq __LOC__ 2 (p_is_int_test `a);
+  eq __LOC__ 3 (p_is_int_test u)
+
 let () = Mt.from_pair_suites __MODULE__ !suites

jscomp/test/poly_variant_test.mli

@@ -37,3 +37,6 @@ val on2 :
 
 val read : string -> string
 val readN : string -> string
+
+val p_is_int_test 
+  : [`a | `b of int] -> int

jscomp/test/record_name_test.ml

@@ -64,7 +64,8 @@ and obj = {
 
 let f4  ({ x; y; z = {hi }}: entry) = 
   (x + y + hi) * 2
-  
+
+
 #if 0 then
 type t5 = {
   x : int ;
@@ -73,4 +74,10 @@ type t5 = {
 }   
 
 let v5  = {x = 3 ; y = 2}
-#end
+#end
+
+type t6 = {
+  x : int [@bs.as "x"];
+  y : int [@bs.as "y"]
+}
+(* allow this case *)

lib/4.06.1/bsdep.ml

@@ -28010,14 +28010,17 @@ let rec check_duplicated_labels_aux
     | {pld_name= ({txt} as pld_name); pld_attributes}::rest ->
         if String_set.mem coll txt then Some            pld_name
         else 
-          let coll = String_set.add coll txt in
+          let coll_with_lbl = String_set.add coll txt in
           match Ext_list.find_opt pld_attributes find_name_with_loc with 
-          | None -> check_duplicated_labels_aux rest coll
+          | None -> check_duplicated_labels_aux rest coll_with_lbl
           | Some ({txt = s;} as l) -> 
-            if String_set.mem coll s then  
+            if String_set.mem coll s  
+              (*use coll to make check a bit looser
+                allow cases like [ x : int [@bs.as "x"]]
+               *) then  
               Some l
             else 
-              check_duplicated_labels_aux rest (String_set.add coll s)
+              check_duplicated_labels_aux rest (String_set.add coll_with_lbl s)
 
 let check_duplicated_labels lbls = 
     check_duplicated_labels_aux lbls String_set.empty             
@@ -40831,7 +40834,7 @@ type t =
   | Blk_constructor of string * int
   | Blk_tuple
   | Blk_array
-  | Blk_variant of string 
+  | Blk_poly_var of string 
   | Blk_record of string array 
   | Blk_module of string list
   | Blk_extension_slot

lib/4.06.1/bsppx.ml

@@ -19116,7 +19116,7 @@ type t =
   | Blk_constructor of string * int
   | Blk_tuple
   | Blk_array
-  | Blk_variant of string 
+  | Blk_poly_var of string 
   | Blk_record of string array 
   | Blk_module of string list
   | Blk_extension_slot