type specialize option for an edge case (fix #4930)

jscomp/core/lam_compile_external_obj.ml

@@ -71,14 +71,15 @@ let assemble_obj_args (labels : External_arg_spec.obj_params)  (args : J.express
       let (accs, eff, assign) as r = aux labels args  in 
       Js_of_lam_option.destruct_optional arg 
         ~for_sure_none:r 
-        ~for_sure_some:(fun x -> let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff 
-            ~arg_label:Arg_label ~arg_type:obj_arg_type x in 
-          begin match acc with 
-          | Splice2 _
-          | Splice0 -> assert false 
-          | Splice1 x ->
-            (Js_op.Lit label, x) :: accs , Ext_list.append new_eff  eff , assign
-          end )
+        ~for_sure_some:(fun x -> 
+            let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff 
+                ~arg_label:Arg_label ~arg_type:obj_arg_type x in 
+            begin match acc with 
+              | Splice2 _
+              | Splice0 -> assert false 
+              | Splice1 x ->
+                (Js_op.Lit label, x) :: accs , Ext_list.append new_eff  eff , assign
+            end )
         ~not_sure:(fun _ -> accs, eff , (arg_kind,arg)::assign )
     | {obj_arg_label = Obj_empty  | Obj_label _ | Obj_optional _  } :: _ , [] -> assert false 
     | [],  _ :: _  -> assert false 
@@ -103,7 +104,7 @@ let assemble_obj_args (labels : External_arg_spec.obj_params)  (args : J.express
       (Ext_list.flat_map assignment (fun 
         ((xlabel : External_arg_spec.obj_param), (arg  : J.expression )) -> 
       match xlabel with 
-      | {obj_arg_label = Obj_optional {name = label} } -> 
+      | {obj_arg_label = Obj_optional {name = label;for_sure_no_nested_option} } -> 
         (* Need make sure whether assignment is effectful or not
           to avoid code duplication
         *)
@@ -113,7 +114,7 @@ let assemble_obj_args (labels : External_arg_spec.obj_params)  (args : J.express
             Lam_compile_external_call.ocaml_to_js_eff 
             ~arg_label:
              Arg_empty ~arg_type:xlabel.obj_arg_type 
-              (Js_of_lam_option.val_from_option arg) in 
+              (if for_sure_no_nested_option then arg else Js_of_lam_option.val_from_option arg) in 
           begin match acc with 
           | Splice1 v  ->                         
             [S.if_ (Js_of_lam_option.is_not_none arg )
@@ -133,7 +134,7 @@ let assemble_obj_args (labels : External_arg_spec.obj_params)  (args : J.express
             ~arg_label:
              Arg_empty
              ~arg_type:xlabel.obj_arg_type             
-              (Js_of_lam_option.val_from_option arg) in 
+              (if for_sure_no_nested_option then arg else Js_of_lam_option.val_from_option arg) in 
           begin match acc with 
           | Splice1 v  ->        
             st ::  

jscomp/frontend/ast_core_type.ml

@@ -56,11 +56,26 @@ open Ast_helper
     | _ -> result in
   aux ty *)
 
+let is_builtin_rank0_type txt =   
+  match txt with 
+  | "int"         
+  | "char"
+  | "bytes"
+  | "float"
+  | "bool"
+  | "unit"
+  | "exn"
+  | "int32"
+  | "int64"
+  | "string" -> true 
+  | _ -> false
+
 let is_unit (ty : t ) =
   match ty.ptyp_desc with
   | Ptyp_constr({txt =Lident "unit"}, []) -> true
   | _ -> false
 
+
 (* let is_array (ty : t) =
   match ty.ptyp_desc with
   | Ptyp_constr({txt =Lident "array"}, [_]) -> true

jscomp/frontend/ast_core_type.mli

@@ -29,13 +29,10 @@ type t = Parsetree.core_type
 
 val lift_option_type : t -> t
 
-(* val replace_result : t -> t -> t *)
-
-(* val opt_arrow: Location.t -> string -> t -> t -> t *)
-
 val is_unit : t -> bool
-(* val is_array : t -> bool *)
 
+val is_builtin_rank0_type : 
+  string -> bool
 
 (** return a function type
     [from_labels ~loc tyvars labels]
@@ -52,11 +49,6 @@ val make_obj :
 
 val is_user_option : t -> bool
 
-(* val is_user_bool : t -> bool
-
-val is_user_int : t -> bool *)
-
-
 
 (**
   returns 0 when it can not tell arity from the syntax

jscomp/frontend/ast_external_process.ml

@@ -492,17 +492,22 @@ let process_obj
                    param_type::arg_types, result_types
                  | Nothing ->
                    let s = (Lam_methname.translate  name) in
-                   {obj_arg_label = External_arg_spec.optional s; obj_arg_type},
+                   let for_sure_not_nested = 
+                     match ty.ptyp_desc with 
+                     | Ptyp_constr({txt = Lident txt;_}, []) ->
+                       Ast_core_type.is_builtin_rank0_type txt
+                     | _ -> false in 
+                   {obj_arg_label = External_arg_spec.optional for_sure_not_nested s; obj_arg_type},
                    param_type :: arg_types,
                    ( Parsetree.Otag ({Asttypes.txt = name; loc}, [], Ast_comb.to_undefined_type loc ty) ::  result_types)
                  | Int _  ->
                    let s = Lam_methname.translate  name in
-                   {obj_arg_label = External_arg_spec.optional s ; obj_arg_type },
+                   {obj_arg_label = External_arg_spec.optional true s ; obj_arg_type },
                    param_type :: arg_types,
                    (Otag ({Asttypes.txt = name; loc}, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
                  | Poly_var_string _ ->
                    let s = Lam_methname.translate  name in
-                   {obj_arg_label = External_arg_spec.optional s ; obj_arg_type },
+                   {obj_arg_label = External_arg_spec.optional true s ; obj_arg_type },
                    param_type::arg_types,
                    (Otag ({Asttypes.txt = name; loc}, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
                  | Arg_cst _
@@ -1020,7 +1025,7 @@ let pval_prim_of_option_labels
           let label_name = Lam_methname.translate  p.txt in
           let obj_arg_label =
             if is_option then
-              External_arg_spec.optional label_name
+              External_arg_spec.optional false label_name
             else External_arg_spec.obj_label label_name 
           in
           {obj_arg_type = Nothing ;

jscomp/frontend/bs_ast_invariant.ml

@@ -117,27 +117,10 @@ let emit_external_warnings : iterator=
     super with
     type_declaration = (fun self ptyp -> 
         let txt = ptyp.ptype_name.txt in
-        (match txt with 
-         | "int"         
-         | "char"
-         | "bytes"
-         | "float"
-         | "bool"
-         | "unit"
-         | "exn"
-         | "int32"
-         | "int64"
-         | "string" 
-         (* not adding parametric types yet 
-         | "array"
-         | "list"
-         | "option"
-         *)
-          ->
-           Location.raise_errorf ~loc:ptyp.ptype_loc 
-           "built-in type `%s` can not be redefined " txt
-         | _ -> ()
-        );
+        if Ast_core_type.is_builtin_rank0_type txt then 
+          Location.raise_errorf ~loc:ptyp.ptype_loc 
+            "built-in type `%s` can not be redefined " txt
+        ;
         super.type_declaration self ptyp
       );
     attribute = (fun _ attr -> warn_unused_attribute attr);

jscomp/frontend/external_arg_spec.ml

@@ -37,7 +37,8 @@ type label_noname =
 type label = 
   | Obj_label of {name : string }
   | Obj_empty 
-  | Obj_optional of {name : string }
+  | Obj_optional of {name : string; for_sure_no_nested_option : bool }
+
   (* it will be ignored , side effect will be recorded *)
 
 
@@ -90,7 +91,8 @@ let empty_label = Obj_empty
 let obj_label name  = 
     Obj_label {name }
 
-let optional name = Obj_optional {name}
+let optional for_sure_no_nested_option name =
+   Obj_optional {name; for_sure_no_nested_option}
 
 let empty_kind obj_arg_type = { obj_arg_label = empty_label ; obj_arg_type }
 let dummy = 

jscomp/frontend/external_arg_spec.mli

@@ -32,7 +32,8 @@ type label = private
   | Obj_label of {name : string}
   | Obj_empty 
 
-  | Obj_optional of {name : string}
+  | Obj_optional of {name : string;
+    for_sure_no_nested_option : bool}
   (* it will be ignored , side effect will be recorded *)
 
 
@@ -83,6 +84,8 @@ val cst_string : string -> cst
 val empty_label : label
 (* val empty_lit : cst -> label  *)
 val obj_label :  string -> label
-val optional  : string -> label
+val optional  : 
+  bool ->
+  string -> label
 val empty_kind : attr -> obj_param
 val dummy : param

jscomp/test/debug_tmp.ml

@@ -1,6 +1,8 @@
 
 [@@@config {
   flags = [|
+  (* "-w";
+  "@A" *)
   (* "-drawlambda"; *)
   (* "-dtypedtree"; *)
   (* "-bs-diagnose"; *)

jscomp/test/gpr_1409_test.js

@@ -52,7 +52,7 @@ function make(foo) {
   return function (param) {
     var tmp = {};
     if (partial_arg !== undefined) {
-      tmp.foo = Caml_option.valFromOption(partial_arg);
+      tmp.foo = partial_arg;
     }
     return tmp;
   };
@@ -79,10 +79,10 @@ function test3(_open, xx__hi) {
     hi: 2
   };
   if (_open !== undefined) {
-    tmp.open = Caml_option.valFromOption(_open);
+    tmp.open = _open;
   }
   if (xx__hi !== undefined) {
-    tmp.xx = Caml_option.valFromOption(xx__hi);
+    tmp.xx = xx__hi;
   }
   return tmp;
 }
@@ -94,7 +94,7 @@ function test4(_open, xx__hi) {
     hi: 2
   };
   if (xx__hi !== undefined) {
-    tmp.xx = Caml_option.valFromOption(xx__hi);
+    tmp.xx = xx__hi;
   }
   return tmp;
 }
@@ -106,11 +106,11 @@ function test5(f, x) {
   };
   var tmp$1 = Curry._1(f, x);
   if (tmp$1 !== undefined) {
-    tmp.open = Caml_option.valFromOption(tmp$1);
+    tmp.open = tmp$1;
   }
   var tmp$2 = Curry._1(f, x);
   if (tmp$2 !== undefined) {
-    tmp.xx = Caml_option.valFromOption(tmp$2);
+    tmp.xx = tmp$2;
   }
   return tmp;
 }
@@ -125,11 +125,11 @@ function test6(f, x) {
   };
   var tmp$1 = (x$1.contents = x$1.contents + 1 | 0, x$1.contents);
   if (tmp$1 !== undefined) {
-    tmp.open = Caml_option.valFromOption(tmp$1);
+    tmp.open = tmp$1;
   }
   var tmp$2 = f(x$1);
   if (tmp$2 !== undefined) {
-    tmp.xx = Caml_option.valFromOption(tmp$2);
+    tmp.xx = tmp$2;
   }
   return tmp;
 }

jscomp/test/test_obj_simple_ffi.js

@@ -1,6 +1,5 @@
 'use strict';
 
-var Caml_option = require("../../lib/js/caml_option.js");
 
 function v(displayName, param) {
   var tmp = {
@@ -9,7 +8,7 @@ function v(displayName, param) {
     hi: "ghos"
   };
   if (displayName !== undefined) {
-    tmp.displayName = Caml_option.valFromOption(displayName);
+    tmp.displayName = displayName;
   }
   return tmp;
 }