diff --git a/jscomp/core/jsoo_main.ml b/jscomp/core/jsoo_main.ml index 04a1b50855..1f61f9e985 100644 --- a/jscomp/core/jsoo_main.ml +++ b/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 diff --git a/jscomp/syntax/ast_attributes.ml b/jscomp/syntax/ast_attributes.ml index 55f1b187a4..03ba91ec08 100644 --- a/jscomp/syntax/ast_attributes.ml +++ b/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 diff --git a/jscomp/syntax/ast_attributes.mli b/jscomp/syntax/ast_attributes.mli index 7949ab5b81..e5f7be8738 100644 --- a/jscomp/syntax/ast_attributes.mli +++ b/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 diff --git a/jscomp/syntax/ast_core_type.ml b/jscomp/syntax/ast_core_type.ml index 8d6f119c6e..421f8c16c8 100644 --- a/jscomp/syntax/ast_core_type.ml +++ b/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) = diff --git a/jscomp/syntax/ast_derive_abstract.ml b/jscomp/syntax/ast_derive_abstract.ml index 59c733a0fb..1a09576f48 100644 --- a/jscomp/syntax/ast_derive_abstract.ml +++ b/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 ([], diff --git a/jscomp/test/gpr_2614_test.ml b/jscomp/test/gpr_2614_test.ml index 0fdb74bf6c..cd116bdb67 100644 --- a/jscomp/test/gpr_2614_test.ml +++ b/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 diff --git a/lib/bsdep.ml b/lib/bsdep.ml index 7620052670..4093a9f518 100644 --- a/lib/bsdep.ml +++ b/lib/bsdep.ml @@ -26284,7 +26284,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) = @@ -28234,7 +28237,7 @@ end module Ast_attributes : sig #1 "ast_attributes.mli" (* 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 @@ -28252,70 +28255,73 @@ module Ast_attributes : sig * 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 iter_process_derive_type : - t -> derive_attr +val process_derive_type : + t -> derive_attr * t +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 end = struct #1 "ast_attributes.ml" @@ -28561,6 +28567,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 @@ -36759,8 +36779,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 @@ -36782,9 +36802,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:( @@ -36797,9 +36824,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"} @@ -36809,10 +36834,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 ([], diff --git a/lib/bsppx.ml b/lib/bsppx.ml index 9f1e57961f..680635575c 100644 --- a/lib/bsppx.ml +++ b/lib/bsppx.ml @@ -8226,7 +8226,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) = @@ -10176,7 +10179,7 @@ end module Ast_attributes : sig #1 "ast_attributes.mli" (* 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 @@ -10194,70 +10197,73 @@ module Ast_attributes : sig * 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 iter_process_derive_type : - t -> derive_attr +val process_derive_type : + t -> derive_attr * t +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 end = struct #1 "ast_attributes.ml" @@ -10503,6 +10509,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 @@ -18764,8 +18784,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 @@ -18787,9 +18807,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:( @@ -18802,9 +18829,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"} @@ -18814,10 +18839,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 ([], diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 6ae4f8362f..6b3cc25b97 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -104095,7 +104095,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) = @@ -105146,7 +105149,7 @@ end module Ast_attributes : sig #1 "ast_attributes.mli" (* 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 @@ -105164,70 +105167,73 @@ module Ast_attributes : sig * 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 end = struct #1 "ast_attributes.ml" @@ -105473,6 +105479,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 @@ -111308,8 +111328,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 @@ -111331,9 +111351,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:( @@ -111346,9 +111373,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"} @@ -111358,10 +111383,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 ([],