explicit for less surprise

jscomp/core/jsoo_main.ml

@@ -126,19 +126,11 @@ let implementation prefix impl  str  : Js.Unsafe.obj =
 
 
 
-let string_of_fmt (f : Format.formatter -> 'a -> unit) v =
-  let buf = Buffer.create 37 in
-  let fmt  = Format.formatter_of_buffer buf in
-  let () =
-    f fmt v;
-    Format.pp_print_flush fmt () in
-  Buffer.contents buf
-
 let compile  impl : string -> Js.Unsafe.obj =
     implementation  false impl
 (** TODO: add `[@@bs.config{no_export}]\n# 1 "repl.ml"`*)
 let shake_compile impl : string -> Js.Unsafe.obj =
-   implementation true impl 
+   implementation true impl
 
 
 

jscomp/syntax/ast_attributes.ml

@@ -240,6 +240,20 @@ let iter_process_bs_string_as  (attrs : t) : string option =
     ) attrs;
   !st
 
+let has_bs_optional  (attrs : t) : bool =
+  List.exists
+    (fun
+      (({txt ; loc}, _payload ) as attr : attr)  ->
+      match  txt with
+      | "bs.optional"
+        ->
+        Bs_ast_invariant.mark_used_bs_attribute attr ;
+        true
+      | _  -> false
+    ) attrs
+
+
+
 let iter_process_bs_int_as  attrs =
   let st = ref None in
   List.iter

jscomp/syntax/ast_attributes.mli

@@ -1,5 +1,5 @@
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- * 
+ *
  * 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
@@ -17,67 +17,70 @@
  * 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 attr =  Parsetree.attribute
-type t =  attr list 
+type t =  attr list
 
-type ('a,'b) st = 
-  { get : 'a option ; 
+type ('a,'b) st =
+  { get : 'a option ;
     set : 'b option }
 
-val process_method_attributes_rev : 
+val process_method_attributes_rev :
   t ->
-  (bool * bool , [`Get | `No_get ]) st * t 
+  (bool * bool , [`Get | `No_get ]) st * t
 
-val process_attributes_rev : 
-  t -> [ `Meth_callback | `Nothing | `Uncurry | `Method ] * t 
+val process_attributes_rev :
+  t -> [ `Meth_callback | `Nothing | `Uncurry | `Method ] * t
 
 val process_pexp_fun_attributes_rev :
-  t -> [ `Nothing | `Exn ] * t 
-val process_bs : 
-  t -> [ `Nothing | `Has] * t 
+  t -> [ `Nothing | `Exn ] * t
+val process_bs :
+  t -> [ `Nothing | `Has] * t
 
-val process_external : t -> bool 
+val process_external : t -> bool
 
 type derive_attr = {
   explict_nonrec : bool;
-  bs_deriving : Ast_payload.action list option 
+  bs_deriving : Ast_payload.action list option
 }
 val process_bs_string_int_unwrap_uncurry :
   t -> [`Nothing | `String | `Int | `Ignore | `Unwrap | `Uncurry of int option ]  * t
 
 
 val iter_process_bs_string_as :
-  t -> string option 
+  t -> string option
 
-val iter_process_bs_int_as : 
-  t -> int option 
+val has_bs_optional :
+  t -> bool 
 
+val iter_process_bs_int_as :
+  t -> int option
 
-val iter_process_bs_string_or_int_as : 
+
+val iter_process_bs_string_or_int_as :
     t ->
-    [ `Int of int 
+    [ `Int of int
     | `Str of string
-    | `Json_str of string  ] option 
-    
+    | `Json_str of string  ] option
+
 
-val process_derive_type : 
-  t -> derive_attr * t 
+val process_derive_type :
+  t -> derive_attr * t
 
-val iter_process_derive_type : 
-  t -> derive_attr  
+val iter_process_derive_type :
+  t -> derive_attr
 
 
-val bs : attr 
+val bs : attr
 val is_bs : attr -> bool
 val bs_this : attr
 val bs_method : attr
-val bs_obj : attr 
+val bs_obj : attr
 
 
-val bs_get : attr 
+val bs_get : attr
 val bs_set : attr
-val bs_return_undefined : attr  
+val bs_return_undefined : attr

jscomp/syntax/ast_core_type.ml

@@ -98,7 +98,10 @@ let is_array (ty : t) =
 
 let is_user_option (ty : t) =
   match ty.ptyp_desc with
-  | Ptyp_constr({txt = Lident "option"},[_]) -> true
+  | Ptyp_constr(
+    {txt = Lident "option" |
+     (Ldot (Lident "*predef*", "option")) },
+    [_]) -> true
   | _ -> false
 
 let is_user_bool (ty : t) =

jscomp/syntax/ast_derive_abstract.ml

@@ -74,8 +74,8 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
   | Ptype_record label_declarations ->
     let is_private = tdcl.ptype_private = Private in
     let has_optional_field =
-      List.exists (fun ({pld_type} : Parsetree.label_declaration) ->
-          Ast_core_type.is_user_option pld_type
+      List.exists (fun ({pld_type; pld_attributes} : Parsetree.label_declaration) ->
+          Ast_attributes.has_bs_optional pld_attributes
         ) label_declarations in
     let setter_accessor, makeType, labels =
       Ext_list.fold_right
@@ -97,9 +97,16 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
             | Some new_name ->
               [new_name], {pld_name with txt = new_name}
           in
-          let is_option = Ast_core_type.is_user_option pld_type in
-          let getter_type =
-            Typ.arrow ~loc "" core_type pld_type in
+          let is_option = Ast_attributes.has_bs_optional pld_attributes in
+          let maker, getter_type =
+            if is_option then
+              let optional_type = Ast_core_type.lift_option_type pld_type in
+              Ast_core_type.opt_arrow pld_loc label_name optional_type maker,
+              Typ.arrow ~loc "" core_type optional_type
+            else
+              Typ.arrow ~loc:pld_loc label_name pld_type maker,
+               Typ.arrow ~loc "" core_type pld_type
+          in
           let acc =
             Val.mk pld_name
               ~attrs:(
@@ -112,9 +119,7 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
               let setter_type =
                 (Typ.arrow "" core_type
                    (Typ.arrow ""
-                      (if is_option then
-                         Ast_core_type.extract_option_type_exn pld_type
-                       else pld_type)
+                      pld_type (* setter *)
                       (Ast_literal.type_unit ()))) in
               Val.mk
                 {loc = label_loc; txt = label_name ^ "Set"}
@@ -124,10 +129,7 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
               :: acc
             else acc in
           acc,
-          (if  is_option then
-             Ast_core_type.opt_arrow pld_loc label_name pld_type maker
-           else Typ.arrow ~loc:pld_loc label_name pld_type maker
-          ),
+          maker,
           (is_option, newLabel)::labels
         ) label_declarations
         ([],

jscomp/test/gpr_2614_test.ml

@@ -28,8 +28,9 @@ let ff () =
 
 
 type a = {
-  mutable low : string option
-      [@bs.as "lo-x"]
+  mutable low : string
+  [@bs.optional]
+  [@bs.as "lo-x"]
 ;
   hi : int
 } [@@bs.deriving abstract]
@@ -62,25 +63,42 @@ let hh2 x =
   | None -> 0
   | Some _ -> 1
 
+
 type css =
   {
-    a0 : int option ;
-    a1 : int option ;
-    a2 : int option ;
-    a3 : int option ;
-    a4 : int option ;
-    a5 : int option ;
-    a6 : int option ;
-    a7 : int option ;
-    a8 : int option ;
-    a9 : int option
+    a0 : int
+    [@bs.optional] ;
+    a1 : int
+    [@bs.optional];
+    a2 : int
+    [@bs.optional];
+    a3 : int
+    [@bs.optional];
+    a4 : int
+    [@bs.optional];
+    a5 : int
+    [@bs.optional];
+    a6 : int
+    [@bs.optional];
+    a7 : int
+    [@bs.optional];
+    a8 : int
+    [@bs.optional];
+    a9 : int
+    [@bs.optional]
     [@bs.as "xx-yy"];
-    a10 : int option ;
-    a11 : int option ;
-    a12 : int option ;
-    a13 : int option ;
-    a14 : int option ;
-    a15 : int option ;
+    a10 : int
+    [@bs.optional];
+    a11 : int
+    [@bs.optional];
+    a12 : int
+    [@bs.optional];
+    a13 : int
+    [@bs.optional];
+    a14 : int
+    [@bs.optional];
+    a15 : int
+    [@bs.optional] ;
   }
   [@@bs.deriving abstract]
 
@@ -89,4 +107,4 @@ let u = css ~a9:3 ()
 let v =
   match u |. a9 with
   | None -> 0
-  | Some x -> x 
+  | Some x -> x