Merge pull request #4565 from BuckleScript/clean_up

bobzhang · web-flow · commit 30223d442886 · 2020-07-24T12:56:46.000+08:00
simplify FFI by taking advantage of polyvar as string
diff --git a/jscomp/common/bs_warnings.ml b/jscomp/common/bs_warnings.ml
@@ -24,25 +24,11 @@
 
 
 
-type t =
-  | Unsafe_poly_variant_type
-  (* for users write code like this:
-     {[ external f : [`a of int ] -> string = ""]}
-     Here users forget about `[@bs.string]` or `[@bs.int]`
-  *)    
 
 
 
-let to_string t =
-  match t with
-  | Unsafe_poly_variant_type 
-    -> 
-    "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]`  "
 
 
-let prerr_bs_ffi_warning loc x =  
-    Location.prerr_warning loc (Bs_ffi_warning (to_string x))
-
 
 
 
diff --git a/jscomp/common/bs_warnings.mli b/jscomp/common/bs_warnings.mli
@@ -23,10 +23,6 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 
-type t =
-  | Unsafe_poly_variant_type
-
-val prerr_bs_ffi_warning : Location.t -> t -> unit
 
 
 val warn_missing_primitive : Location.t -> string -> unit 
diff --git a/jscomp/core/js_of_lam_variant.ml b/jscomp/core/js_of_lam_variant.ml
@@ -31,39 +31,57 @@ type arg_expression =
   | Splice2 of E.t * E.t
 
 (* we need destruct [undefined] when input is optional *)
-let eval (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list ) : E.t =
-  if arg == E.undefined then E.undefined else
-  match arg.expression_desc with
-  | Str (_,s) -> 
-    E.str (Ext_list.assoc_by_string  dispatches s None)
-  | _ ->
-    E.of_block
-      [(S.string_switch arg
-      (Ext_list.map dispatches (fun (i,r) ->
-              {J.switch_case = i ;
-               switch_body = [S.return_stmt (E.str r)];
-               should_break = false; (* FIXME: if true, still print break*)
-               comment = None;
-              })))]
+let eval (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list option) : E.t =
+  match dispatches with 
+  | None -> arg 
+  | Some dispatches -> 
+    if arg == E.undefined then E.undefined 
+    else
+      match arg.expression_desc with
+      | Str (_,s) ->     
+        let s = 
+          (Ext_list.assoc_by_string  dispatches s None) in 
+        E.str s 
+      | _ -> 
+        E.of_block
+          [(S.string_switch arg
+              (Ext_list.map dispatches (fun (i,r) ->
+                   {J.switch_case = i ;
+                    switch_body = [S.return_stmt (E.str r)];
+                    should_break = false; (* FIXME: if true, still print break*)
+                    comment = None;
+                   })))]
 
 (** invariant: optional is not allowed in this case *)
 (** arg is a polyvar *)
-let eval_as_event (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list ) =
+let eval_as_event (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list option) =
   match arg.expression_desc with
   | Caml_block([{expression_desc = Str(_,s)}; cb], _, _, Blk_poly_var ) when Js_analyzer.no_side_effect_expression cb 
     -> 
-    let v = Ext_list.assoc_by_string dispatches s None in
+    let v = 
+      match dispatches with 
+      | Some dispatches ->   
+        Ext_list.assoc_by_string dispatches s None 
+      | None -> s in
     Splice2(E.str v , cb )
   | _ ->
     Splice2
-      (E.of_block
-      [(S.string_switch (E.poly_var_tag_access arg)
-      (Ext_list.map dispatches (fun (i,r) ->
+      (
+        (match dispatches with 
+        | Some dispatches ->     
+        E.of_block
+      [
+      
+        (S.string_switch (E.poly_var_tag_access arg)
+        (Ext_list.map dispatches (fun (i,r) ->
               {J.switch_case = i ;
                switch_body = [S.return_stmt (E.str r)];
                should_break = false; (* FIXME: if true, still print break*)
                comment = None;
-              }) ))]
+              }) ))
+
+        ]
+        | None -> E.poly_var_tag_access arg )
       , (* TODO: improve, one dispatch later,
            the problem is that we can not create bindings
            due to the
diff --git a/jscomp/core/js_of_lam_variant.mli b/jscomp/core/js_of_lam_variant.mli
@@ -30,9 +30,18 @@ type arg_expression =
   | Splice2 of J.expression * J.expression
   
 val eval :
-   J.expression -> (Ast_compatible.hash_label * string) list -> J.expression
+   J.expression -> 
+   (Ast_compatible.hash_label * string) list option
+   -> J.expression
+
 val eval_as_event : 
-  J.expression -> (Ast_compatible.hash_label * string) list -> arg_expression
+  J.expression -> 
+  (Ast_compatible.hash_label * string) list option 
+  -> arg_expression
+
 val eval_as_int : 
-  J.expression -> (Ast_compatible.hash_label * int) list -> J.expression
+  J.expression -> 
+  (Ast_compatible.hash_label * int) list -> 
+  J.expression
+
 val eval_as_unwrap : J.expression -> J.expression
diff --git a/jscomp/core/lam_compile_external_call.ml b/jscomp/core/lam_compile_external_call.ml
@@ -118,9 +118,9 @@ let ocaml_to_js_eff
        []
      else 
        [arg])
-  | NullString dispatches -> 
+  | Poly_var {has_payload = false ; descr = dispatches} -> 
     Splice1 (Js_of_lam_variant.eval arg dispatches),[]
-  | NonNullString dispatches -> 
+  | Poly_var {has_payload = true ; descr = dispatches} -> 
     Js_of_lam_variant.eval_as_event arg dispatches,[]    
     (* FIXME: encode invariant below in the signature*)
     (* length of 2
diff --git a/jscomp/main/builtin_cmi_datasets.ml b/jscomp/main/builtin_cmi_datasets.ml
diff --git a/jscomp/syntax/ast_external_process.ml b/jscomp/syntax/ast_external_process.ml
@@ -90,9 +90,6 @@ let spec_of_ptyp
     begin match ptyp_desc with
       | Ptyp_constr ({txt = Lident "unit"; _}, [])
         -> if nolabel then Extern_unit else  Nothing
-      | Ptyp_variant _ ->
-        Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
-        Nothing
       | _ ->
         Nothing
     end
@@ -440,7 +437,7 @@ let process_obj
                    {obj_arg_label = External_arg_spec.obj_label s; obj_arg_type},
                    {param_type with ty = new_ty}::arg_types,
                    (({Asttypes.txt = name; loc}, [], Ast_literal.type_int ~loc ()) :: result_types)
-                 | NullString _ ->
+                 | Poly_var { has_payload = false ; _} ->
                    let s = Lam_methname.translate  name in
                    {obj_arg_label = External_arg_spec.obj_label s; obj_arg_type},
                    {param_type with ty = new_ty }::arg_types,
@@ -449,7 +446,7 @@ let process_obj
                    Location.raise_errorf ~loc
                      "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
                  | Extern_unit -> assert false
-                 | NonNullString _
+                 | Poly_var { has_payload = true ; _} 
                    ->
                    Location.raise_errorf ~loc
                      "bs.obj label %s does not support such arg type" name
@@ -473,7 +470,7 @@ let process_obj
                    {obj_arg_label = External_arg_spec.optional s ; obj_arg_type },
                    param_type :: arg_types,
                    (({Asttypes.txt = name; loc}, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
-                 | NullString _  ->
+                 | Poly_var {has_payload = false ; _} ->
                    let s = Lam_methname.translate  name in
                    {obj_arg_label = External_arg_spec.optional s ; obj_arg_type },
                    param_type::arg_types,
@@ -485,7 +482,7 @@ let process_obj
                    Location.raise_errorf ~loc
                      "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
                  | Extern_unit   -> assert false
-                 | NonNullString _
+                 | Poly_var {has_payload = true; _}
                    ->
                    Location.raise_errorf ~loc
                      "bs.obj label %s does not support such arg type" name
@@ -899,7 +896,7 @@ let handle_attributes
              | Optional s  ->
                let arg_type = get_opt_arg_type ~nolabel:false ty in
                begin match arg_type with
-                 | NonNullString _ ->
+                 | Poly_var {has_payload = true; _} ->
                    (* ?x:([`x of int ] [@bs.string]) does not make sense *)
                    Location.raise_errorf
                      ~loc
diff --git a/jscomp/syntax/ast_polyvar.ml b/jscomp/syntax/ast_polyvar.ml
@@ -84,35 +84,36 @@ let map_constructor_declarations_into_ints
 *)  
 let map_row_fields_into_strings ptyp_loc 
     (row_fields : Parsetree.row_field list) : External_arg_spec.attr = 
+  let has_bs_as = ref false in 
   let case, result = 
     Ext_list.fold_right row_fields (`Nothing, []) (fun tag (nullary, acc) -> 
         match nullary, tag with 
         | (`Nothing | `Null), 
           Rtag (label, attrs, true,  [])
           -> 
-          begin match Ast_attributes.iter_process_bs_string_as attrs with 
+          let name = 
+            match Ast_attributes.iter_process_bs_string_as attrs with 
             | Some name -> 
-              `Null, ((Ast_compatible.hash_label label, name) :: acc )
-
-            | None -> 
-              `Null, ((Ast_compatible.hash_label label, Ast_compatible.label_of_name label) :: acc )
-          end
+              has_bs_as := true; name
+            | None -> label.txt 
+          in `Null, (label.txt, name) :: acc 
         | (`Nothing | `NonNull), Rtag(label, attrs, false, ([ _ ])) 
           -> 
-          begin match Ast_attributes.iter_process_bs_string_as attrs with 
+          let name = 
+            match Ast_attributes.iter_process_bs_string_as attrs with 
             | Some name -> 
-              `NonNull, ((Ast_compatible.hash_label label, name) :: acc)
-            | None -> 
-              `NonNull, ((Ast_compatible.hash_label label, Ast_compatible.label_of_name label) :: acc)
-          end
+              has_bs_as := true; name
+            | None -> label.txt
+          in `NonNull, (label.txt, name) :: acc
         | _ -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
 
       )  in 
   match case with 
   | `Nothing -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
-  | `Null -> External_arg_spec.NullString result 
-  | `NonNull -> NonNullString result
-
+  | `Null 
+  | `NonNull -> 
+    External_arg_spec.Poly_var {has_payload = case = `NonNull ; 
+    descr = if !has_bs_as then Some result else None }
 
 let is_enum row_fields = 
   List.for_all (fun (x : Parsetree.row_field) -> 
diff --git a/jscomp/syntax/external_arg_spec.ml b/jscomp/syntax/external_arg_spec.ml
@@ -45,9 +45,16 @@ type label =
   | Obj_optional of {name : string }
   (* it will be ignored , side effect will be recorded *)
 
+
+
 type attr = 
-  | NullString of (Ast_compatible.hash_label * string) list (* `a does not have any value*)
-  | NonNullString of (Ast_compatible.hash_label * string) list (* `a of int *)
+  | Poly_var of { 
+    has_payload : bool ; 
+    descr :
+    (Ast_compatible.hash_label * string) list
+    option
+  }  
+   (* `a does not have any value*)
   | Int of (Ast_compatible.hash_label * int ) list (* ([`a | `b ] [@bs.int])*)
   | Arg_cst of cst
   | Fn_uncurry_arity of int (* annotated with [@bs.uncurry ] or [@bs.uncurry 2]*)
diff --git a/jscomp/syntax/external_arg_spec.mli b/jscomp/syntax/external_arg_spec.mli
@@ -33,15 +33,20 @@ type cst = private
 
 type label = private
   | Obj_label of {name : string}
-  (* | Obj_labelCst of {name : string ; cst : cst} *)
   | Obj_empty 
   
   | Obj_optional of {name : string}
   (* it will be ignored , side effect will be recorded *)
 
+
+
 type attr = 
-  | NullString of (Ast_compatible.hash_label * string) list (* `a does not have any value*)
-  | NonNullString of (Ast_compatible.hash_label * string) list (* `a of int *)
+  | Poly_var of  {
+      has_payload : bool ; 
+      descr :
+        (Ast_compatible.hash_label * string) 
+          list option
+    }  
   | Int of (Ast_compatible.hash_label * int ) list (* ([`a | `b ] [@bs.int])*)
   | Arg_cst of cst
   | Fn_uncurry_arity of int (* annotated with [@bs.uncurry ] or [@bs.uncurry 2]*)
diff --git a/jscomp/test/gpr_2503_test.js b/jscomp/test/gpr_2503_test.js
@@ -22,31 +22,15 @@ function b(loc, b$1) {
 function makeWrapper(foo, param) {
   var tmp = {};
   if (foo !== undefined) {
-    tmp.foo = (function () {
-          switch (Caml_option.valFromOption(foo)) {
-            case "a" :
-                return "a";
-            case "b" :
-                return "b";
-            
-          }
-        })();
+    tmp.foo = Caml_option.valFromOption(foo);
   }
   console.log(tmp);
   
 }
 
 function makeWrapper2(foo, param) {
   console.log({
-        foo: (function () {
-              switch (foo) {
-                case "a" :
-                    return "a";
-                case "b" :
-                    return "b";
-                
-              }
-            })()
+        foo: foo
       });
   
 }
@@ -57,15 +41,7 @@ function makeWrapper3(foo, param) {
   console.log(2);
   var tmp = {};
   if (foo !== undefined) {
-    tmp.foo = (function () {
-          switch (Caml_option.valFromOption(foo)) {
-            case "a" :
-                return "a";
-            case "b" :
-                return "b";
-            
-          }
-        })();
+    tmp.foo = Caml_option.valFromOption(foo);
   }
   return tmp;
 }
@@ -77,15 +53,7 @@ function makeWrapper4(foo, param) {
       foo > 10 ? "b" : "a"
     );
   if (tmp$1 !== undefined) {
-    tmp.foo = (function () {
-          switch (Caml_option.valFromOption(tmp$1)) {
-            case "a" :
-                return "a";
-            case "b" :
-                return "b";
-            
-          }
-        })();
+    tmp.foo = Caml_option.valFromOption(tmp$1);
   }
   return tmp;
 }
diff --git a/jscomp/test/gpr_2633_test.js b/jscomp/test/gpr_2633_test.js
@@ -3,28 +3,12 @@
 var Curry = require("../../lib/js/curry.js");
 
 function on1(foo, $$event) {
-  foo.on((function () {
-            switch ($$event.NAME) {
-              case "bar" :
-                  return "bar";
-              case "foo" :
-                  return "foo";
-              
-            }
-          })(), $$event.VAL);
+  foo.on($$event.NAME, $$event.VAL);
   
 }
 
 function on2(foo, h, $$event) {
-  foo.on((function () {
-            switch (Curry._1(h, $$event).NAME) {
-              case "bar" :
-                  return "bar";
-              case "foo" :
-                  return "foo";
-              
-            }
-          })(), Curry._1(h, $$event).VAL);
+  foo.on(Curry._1(h, $$event).NAME, Curry._1(h, $$event).VAL);
   
 }
 
diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml
diff --git a/lib/4.06.1/unstable/js_refmt_compiler.ml b/lib/4.06.1/unstable/js_refmt_compiler.ml
diff --git a/lib/4.06.1/unstable/native_ppx.ml b/lib/4.06.1/unstable/native_ppx.ml
diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml
