diff --git a/jscomp/core/bs_conditional_initial.ml b/jscomp/core/bs_conditional_initial.ml index 5be890c708..b93569e11f 100644 --- a/jscomp/core/bs_conditional_initial.ml +++ b/jscomp/core/bs_conditional_initial.ml @@ -25,7 +25,7 @@ let setup_env () = #if BS_DEBUG then - Js_config.set_debug_file "gpr_2487.ml"; + Js_config.set_debug_file "gpr_2503_test.ml"; #end Lexer.replace_directive_bool "BS" true; Lexer.replace_directive_string "BS_VERSION" Bs_version.version diff --git a/jscomp/core/lam_compile_external_call.ml b/jscomp/core/lam_compile_external_call.ml index 6d83fbe5f4..0b3652bc4a 100644 --- a/jscomp/core/lam_compile_external_call.ml +++ b/jscomp/core/lam_compile_external_call.ml @@ -72,7 +72,7 @@ let handle_external_opt This would not work with [NonNullString] *) let ocaml_to_js_eff - ({ External_arg_spec.arg_label; arg_type }) + ({arg_label; arg_type }: External_arg_spec.t) (raw_arg : J.expression) : E.t list * E.t list = let arg = @@ -101,7 +101,12 @@ let ocaml_to_js_eff | NullString dispatches -> [Js_of_lam_variant.eval arg dispatches],[] | NonNullString dispatches -> - Js_of_lam_variant.eval_as_event arg dispatches,[] + Js_of_lam_variant.eval_as_event arg dispatches,[] + (* FIXME: encode invariant below in the signature*) + (* length of 2 + - the poly var tag + - the value + *) | Int dispatches -> [Js_of_lam_variant.eval_as_int arg dispatches],[] | Unwrap -> @@ -275,7 +280,7 @@ let translate_ffi name = fn; splice ; scopes - } -> + } -> (* handle [@@bs.new]*) (* This has some side effect, it will mark its identifier (If it has) as an object, ATTENTION: diff --git a/jscomp/core/lam_compile_external_obj.ml b/jscomp/core/lam_compile_external_obj.ml index d52bb7ad0b..f276949e01 100644 --- a/jscomp/core/lam_compile_external_obj.ml +++ b/jscomp/core/lam_compile_external_obj.ml @@ -74,7 +74,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | Array ([x],_) | Caml_block ([x],_,_,_) -> let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff - ({External_arg_spec.arg_label = External_arg_spec.label label None; arg_type}) x in + ({arg_label = External_arg_spec.label label None; arg_type}) x in begin match acc with | [] -> assert false | x::xs -> @@ -104,21 +104,48 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | x::xs -> E.seq (E.fuse_to_seq x xs) (E.obj map) end) :: (Ext_list.flat_map (fun - ((label : External_arg_spec.t), (arg : J.expression )) -> - match label with + ((xlabel : External_arg_spec.t), (arg : J.expression )) -> + match xlabel with | {arg_label = Optional label } -> (* Need make sure whether assignment is effectful or not to avoid code duplication *) begin match Js_ast_util.named_expression arg with | None -> - [S.if_ arg [S.exp (E.assign (E.dot var_v label) - (E.index arg 0l) ) ] ] - | Some (st,id) -> - let var_id = E.var id in - st :: - [S.if_ var_id [S.exp (E.assign (E.dot var_v label) - (E.index var_id 0l)) ]] + let acc,new_eff = + Lam_compile_external_call.ocaml_to_js_eff + {xlabel with arg_label = + External_arg_spec.empty_label} + (E.index arg 0l ) in + begin match acc with + | [ v ] -> + [S.if_ arg [S.exp (E.assign (E.dot var_v label) + ( + match new_eff with + | [] -> v + | x :: xs -> + E.seq (E.fuse_to_seq x xs ) v + ) ) ] ] + |_ -> assert false + end + | Some (st,id) -> (* FIXME: see #2503 *) + let arg = E.var id in + let acc,new_eff = + Lam_compile_external_call.ocaml_to_js_eff + {xlabel with arg_label = + External_arg_spec.empty_label} + (E.index arg 0l ) in + begin match acc with + | [ v ] -> + st :: + [S.if_ arg [S.exp (E.assign (E.dot var_v label) + (match new_eff with + | [] -> v + | x :: xs -> + E.seq (E.fuse_to_seq x xs) v + )) ]] + | _ -> assert false + end end | _ -> assert false ) diff --git a/jscomp/others/belt_Map.mli b/jscomp/others/belt_Map.mli index 2d2ba3b837..ff4a054aae 100644 --- a/jscomp/others/belt_Map.mli +++ b/jscomp/others/belt_Map.mli @@ -511,6 +511,6 @@ val packIdData: id:('a, 'b) id -> data:('a, 'c, 'b) Belt_MapDict.t -> ('a, 'c, ' (**/**) val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (**/**) diff --git a/jscomp/others/belt_MapDict.mli b/jscomp/others/belt_MapDict.mli index 8ffd7f9de5..ad2db15ee1 100644 --- a/jscomp/others/belt_MapDict.mli +++ b/jscomp/others/belt_MapDict.mli @@ -124,7 +124,7 @@ val getExn: val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) val remove: diff --git a/jscomp/others/belt_MapInt.mli b/jscomp/others/belt_MapInt.mli index ad14316d54..3a4c54462d 100644 --- a/jscomp/others/belt_MapInt.mli +++ b/jscomp/others/belt_MapInt.mli @@ -64,7 +64,7 @@ val getExn: 'a t -> key -> 'a val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (****************************************************************************) @@ -151,7 +151,7 @@ val mapWithKey: 'a t -> (key -> 'a -> 'b) -> 'b t (**/**) val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (**/**) diff --git a/jscomp/others/belt_MapString.mli b/jscomp/others/belt_MapString.mli index 7a8ba4fa51..52e575378c 100644 --- a/jscomp/others/belt_MapString.mli +++ b/jscomp/others/belt_MapString.mli @@ -64,7 +64,7 @@ val getExn: 'a t -> key -> 'a val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (****************************************************************************) @@ -151,7 +151,7 @@ val mapWithKey: 'a t -> (key -> 'a -> 'b) -> 'b t (**/**) val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (**/**) diff --git a/jscomp/others/belt_MutableMap.mli b/jscomp/others/belt_MutableMap.mli index 64aad3f006..009e8c55fe 100644 --- a/jscomp/others/belt_MutableMap.mli +++ b/jscomp/others/belt_MutableMap.mli @@ -158,7 +158,7 @@ val getWithDefault: val getExn: ('k, 'a, 'id) t -> 'k -> 'a val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (****************************************************************************) diff --git a/jscomp/others/belt_MutableMapInt.mli b/jscomp/others/belt_MutableMapInt.mli index a4436fe83c..84e3308ac1 100644 --- a/jscomp/others/belt_MutableMapInt.mli +++ b/jscomp/others/belt_MutableMapInt.mli @@ -97,7 +97,7 @@ val getWithDefault: 'a t -> key -> 'a -> 'a val getExn: 'a t -> key -> 'a val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/belt_MutableMapString.mli b/jscomp/others/belt_MutableMapString.mli index 2361a400bd..72cc19f2ed 100644 --- a/jscomp/others/belt_MutableMapString.mli +++ b/jscomp/others/belt_MutableMapString.mli @@ -97,7 +97,7 @@ val getWithDefault: 'a t -> key -> 'a -> 'a val getExn: 'a t -> key -> 'a val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/belt_MutableSet.mli b/jscomp/others/belt_MutableSet.mli index a3a8117d99..4bb64a5753 100644 --- a/jscomp/others/belt_MutableSet.mli +++ b/jscomp/others/belt_MutableSet.mli @@ -181,7 +181,7 @@ val split: ('elt, 'id) t -> 'elt -> (('elt, 'id) t * ('elt, 'id) t) * bool val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (* diff --git a/jscomp/others/belt_MutableSetInt.mli b/jscomp/others/belt_MutableSetInt.mli index 09a62a7faa..47bd648bd7 100644 --- a/jscomp/others/belt_MutableSetInt.mli +++ b/jscomp/others/belt_MutableSetInt.mli @@ -116,7 +116,7 @@ val split: t -> elt -> (t * t) * bool val checkInvariantInternal: t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/belt_MutableSetString.mli b/jscomp/others/belt_MutableSetString.mli index ed964a0e7f..cc0ccbf598 100644 --- a/jscomp/others/belt_MutableSetString.mli +++ b/jscomp/others/belt_MutableSetString.mli @@ -116,7 +116,7 @@ val split: t -> elt -> (t * t) * bool val checkInvariantInternal: t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/belt_Set.mli b/jscomp/others/belt_Set.mli index cd7b37fee1..f16c112ad0 100644 --- a/jscomp/others/belt_Set.mli +++ b/jscomp/others/belt_Set.mli @@ -272,8 +272,8 @@ val subset: ('elt, 'id) t -> ('elt, 'id) t -> bool let s1 = ofArray ~id:(module IntCmp) [|5;2;3;1;5;4;|];; let s2 = intersect s0 s1;; subset s2 s0 = true;; - subset s1 s0 = true;; - subset s1 s2 = false;; + subset s2 s1 = true;; + subset s1 s0 = false;; ]} *) @@ -425,7 +425,7 @@ val split: ('elt, 'id) t -> 'elt -> (('elt, 'id) t * ('elt, 'id) t) * bool (**/**) val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (**/**) diff --git a/jscomp/others/belt_SetDict.mli b/jscomp/others/belt_SetDict.mli index d0c965bb87..766eeef8be 100644 --- a/jscomp/others/belt_SetDict.mli +++ b/jscomp/others/belt_SetDict.mli @@ -150,7 +150,7 @@ val split: ('elt, 'id) t -> 'elt -> val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/belt_SetInt.mli b/jscomp/others/belt_SetInt.mli index de1fdb9dda..4131a07757 100644 --- a/jscomp/others/belt_SetInt.mli +++ b/jscomp/others/belt_SetInt.mli @@ -129,7 +129,7 @@ val split: t -> elt -> (t * t) * bool val checkInvariantInternal: t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/belt_SetString.mli b/jscomp/others/belt_SetString.mli index d3dbc1004f..ae6820ca24 100644 --- a/jscomp/others/belt_SetString.mli +++ b/jscomp/others/belt_SetString.mli @@ -129,7 +129,7 @@ val split: t -> elt -> (t * t) * bool val checkInvariantInternal: t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/belt_internalAVLset.mli b/jscomp/others/belt_internalAVLset.mli index 558621affc..1d73f68b3b 100644 --- a/jscomp/others/belt_internalAVLset.mli +++ b/jscomp/others/belt_internalAVLset.mli @@ -97,7 +97,7 @@ val size: 'a t -> int val toList: 'a t -> 'a list val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) val fillArray: 'a node -> int -> 'a array -> int val toArray: 'a t -> 'a array diff --git a/jscomp/others/belt_internalAVLtree.mli b/jscomp/others/belt_internalAVLtree.mli index e8b50126ef..682d7f35ca 100644 --- a/jscomp/others/belt_internalAVLtree.mli +++ b/jscomp/others/belt_internalAVLtree.mli @@ -131,7 +131,7 @@ val size : ('a,'b) t -> int val toList : ('a,'b) t -> ('a * 'b) list val checkInvariantInternal : ('a,'b) t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/map.cppo.mli b/jscomp/others/map.cppo.mli index 2b722d836f..bde6608c82 100644 --- a/jscomp/others/map.cppo.mli +++ b/jscomp/others/map.cppo.mli @@ -68,7 +68,7 @@ val getExn: 'a t -> key -> 'a val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (****************************************************************************) @@ -155,7 +155,7 @@ val mapWithKey: 'a t -> (key -> 'a -> 'b) -> 'b t (**/**) val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) (**/**) diff --git a/jscomp/others/mapm.cppo.mli b/jscomp/others/mapm.cppo.mli index 33784eb03f..670d1bb638 100644 --- a/jscomp/others/mapm.cppo.mli +++ b/jscomp/others/mapm.cppo.mli @@ -100,7 +100,7 @@ val getWithDefault: 'a t -> key -> 'a -> 'a val getExn: 'a t -> key -> 'a val checkInvariantInternal: _ t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/set.cppo.mli b/jscomp/others/set.cppo.mli index 244b0fc419..b4f006c76e 100644 --- a/jscomp/others/set.cppo.mli +++ b/jscomp/others/set.cppo.mli @@ -132,7 +132,7 @@ val split: t -> elt -> (t * t) * bool val checkInvariantInternal: t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/others/setm.cppo.mli b/jscomp/others/setm.cppo.mli index b5d4344999..379c09d304 100644 --- a/jscomp/others/setm.cppo.mli +++ b/jscomp/others/setm.cppo.mli @@ -119,7 +119,7 @@ val split: t -> elt -> (t * t) * bool val checkInvariantInternal: t -> unit (** - {b raise} when invariant is not helld + {b raise} when invariant is not held *) diff --git a/jscomp/test/.depend b/jscomp/test/.depend index 59df42a148..2e3030de9b 100644 --- a/jscomp/test/.depend +++ b/jscomp/test/.depend @@ -302,7 +302,7 @@ gpr_2250_test.cmj : mt.cmj gpr_2316_test.cmj : mt.cmj ../runtime/js.cmj gpr_2474.cmj : gpr_2487.cmj : ../others/belt.cmj -gpr_2503_test.cmj : ../runtime/js.cmj +gpr_2503_test.cmj : mt.cmj ../runtime/js.cmj gpr_405_test.cmj : ../stdlib/hashtbl.cmj gpr_405_test.cmi gpr_441.cmj : gpr_459_test.cmj : mt.cmj diff --git a/jscomp/test/gpr_2503_test.js b/jscomp/test/gpr_2503_test.js index 45c81e1ee6..b91622618d 100644 --- a/jscomp/test/gpr_2503_test.js +++ b/jscomp/test/gpr_2503_test.js @@ -1,16 +1,108 @@ 'use strict'; +var Mt = require("./mt.js"); + +var suites = [/* [] */0]; + +var test_id = [0]; + +function eq(loc, x, y) { + return Mt.eq_suites(test_id, suites, loc, x, y); +} + +function b(loc, b$1) { + return Mt.bool_suites(test_id, suites, loc, b$1); +} function makeWrapper(foo, _) { var tmp = { }; if (foo) { - tmp.foo = foo[0]; + tmp.foo = (function () { + switch (foo[0]) { + case 97 : + return "a"; + case 98 : + return "b"; + + } + })(); } console.log(tmp); return /* () */0; } -makeWrapper(/* Some */[/* a */97], /* () */0); +function makeWrapper2(foo, _) { + console.log({ + foo: (function () { + switch (foo) { + case 97 : + return "a"; + case 98 : + return "b"; + + } + })() + }); + return /* () */0; +} + +makeWrapper2(/* a */97, /* () */0); + +function makeWrapper3(foo, _) { + console.log(2); + var tmp = { }; + if (foo) { + tmp.foo = (function () { + switch (foo[0]) { + case 97 : + return "a"; + case 98 : + return "b"; + + } + })(); + } + return tmp; +} + +function makeWrapper4(foo, _) { + console.log(2); + var tmp = { }; + var tmp$1 = foo > 100 ? /* None */0 : ( + foo > 10 ? /* Some */[/* b */98] : /* Some */[/* a */97] + ); + if (tmp$1) { + tmp.foo = (function () { + switch (tmp$1[0]) { + case 97 : + return "a"; + case 98 : + return "b"; + + } + })(); + } + return tmp; +} + +b("File \"gpr_2503_test.ml\", line 31, characters 5-12", +("a" === makeWrapper3(/* Some */[/* a */97], /* () */0).foo)); + +b("File \"gpr_2503_test.ml\", line 34, characters 5-12", +(undefined === makeWrapper3(/* None */0, /* () */0).foo)); + +b("File \"gpr_2503_test.ml\", line 37, characters 5-12", +("a" === makeWrapper4(1, /* () */0).foo)); + +b("File \"gpr_2503_test.ml\", line 40, characters 5-12", +("b" === makeWrapper4(11, /* () */0).foo)); + +b("File \"gpr_2503_test.ml\", line 43, characters 5-12", +(undefined === makeWrapper4(111, /* () */0).foo)); + +Mt.from_pair_suites("gpr_2503_test.ml", suites[0]); +exports.suites = suites; +exports.test_id = test_id; +exports.eq = eq; +exports.b = b; exports.makeWrapper = makeWrapper; +exports.makeWrapper2 = makeWrapper2; +exports.makeWrapper3 = makeWrapper3; +exports.makeWrapper4 = makeWrapper4; /* Not a pure module */ diff --git a/jscomp/test/gpr_2503_test.ml b/jscomp/test/gpr_2503_test.ml index bd9cf4aac2..9116054bb9 100644 --- a/jscomp/test/gpr_2503_test.ml +++ b/jscomp/test/gpr_2503_test.ml @@ -1,11 +1,46 @@ +let suites = ref [] +let test_id = ref 0 +let eq loc x y = Mt.eq_suites ~suites ~test_id loc x y - +let b loc b = Mt.bool_suites ~suites ~test_id loc b (* TODO:*) external make: ?foo:([`a|`b] [@bs.string]) -> unit -> _ = "" [@@bs.obj] let makeWrapper ?foo () = Js.log (make ?foo ()) + +external make2: foo:([`a|`b] [@bs.string]) -> unit -> _ = "" [@@bs.obj] + +let makeWrapper2 foo () = Js.log (make2 foo ()) + let _ = - makeWrapper ~foo:`a () - \ No newline at end of file + makeWrapper2 `a () + + +external make3: ?foo:([`a|`b] [@bs.string]) -> unit -> _ = "" [@@bs.obj] + +let makeWrapper3 ?foo () = Js.log 2; (make ?foo ()) + +let makeWrapper4 foo () = Js.log 2; + (make ?foo:(if foo > 100 then None + else if foo > 10 then Some `b + else Some `a) ()) + + +;; b __LOC__ +( Js.eqUndefined "a" (makeWrapper3 ~foo:`a ())##foo) + +;; b __LOC__ +( Js.undefined = (makeWrapper3 ())##foo) + +;; b __LOC__ +(Js.eqUndefined "a" (makeWrapper4 1 ())##foo) + +;; b __LOC__ +(Js.eqUndefined "b" (makeWrapper4 11 ())##foo) + +;; b __LOC__ +(Js.undefined = (makeWrapper4 111 ())##foo) + +;; Mt.from_pair_suites __FILE__ !suites \ No newline at end of file diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 253165a756..9a291132be 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -93574,7 +93574,7 @@ let handle_external_opt This would not work with [NonNullString] *) let ocaml_to_js_eff - ({ External_arg_spec.arg_label; arg_type }) + ({arg_label; arg_type }: External_arg_spec.t) (raw_arg : J.expression) : E.t list * E.t list = let arg = @@ -93603,7 +93603,12 @@ let ocaml_to_js_eff | NullString dispatches -> [Js_of_lam_variant.eval arg dispatches],[] | NonNullString dispatches -> - Js_of_lam_variant.eval_as_event arg dispatches,[] + Js_of_lam_variant.eval_as_event arg dispatches,[] + (* FIXME: encode invariant below in the signature*) + (* length of 2 + - the poly var tag + - the value + *) | Int dispatches -> [Js_of_lam_variant.eval_as_int arg dispatches],[] | Unwrap -> @@ -93777,7 +93782,7 @@ let translate_ffi name = fn; splice ; scopes - } -> + } -> (* handle [@@bs.new]*) (* This has some side effect, it will mark its identifier (If it has) as an object, ATTENTION: @@ -94010,7 +94015,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | Array ([x],_) | Caml_block ([x],_,_,_) -> let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff - ({External_arg_spec.arg_label = External_arg_spec.label label None; arg_type}) x in + ({arg_label = External_arg_spec.label label None; arg_type}) x in begin match acc with | [] -> assert false | x::xs -> @@ -94040,21 +94045,48 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | x::xs -> E.seq (E.fuse_to_seq x xs) (E.obj map) end) :: (Ext_list.flat_map (fun - ((label : External_arg_spec.t), (arg : J.expression )) -> - match label with + ((xlabel : External_arg_spec.t), (arg : J.expression )) -> + match xlabel with | {arg_label = Optional label } -> (* Need make sure whether assignment is effectful or not to avoid code duplication *) begin match Js_ast_util.named_expression arg with | None -> - [S.if_ arg [S.exp (E.assign (E.dot var_v label) - (E.index arg 0l) ) ] ] - | Some (st,id) -> - let var_id = E.var id in - st :: - [S.if_ var_id [S.exp (E.assign (E.dot var_v label) - (E.index var_id 0l)) ]] + let acc,new_eff = + Lam_compile_external_call.ocaml_to_js_eff + {xlabel with arg_label = + External_arg_spec.empty_label} + (E.index arg 0l ) in + begin match acc with + | [ v ] -> + [S.if_ arg [S.exp (E.assign (E.dot var_v label) + ( + match new_eff with + | [] -> v + | x :: xs -> + E.seq (E.fuse_to_seq x xs ) v + ) ) ] ] + |_ -> assert false + end + | Some (st,id) -> (* FIXME: see #2503 *) + let arg = E.var id in + let acc,new_eff = + Lam_compile_external_call.ocaml_to_js_eff + {xlabel with arg_label = + External_arg_spec.empty_label} + (E.index arg 0l ) in + begin match acc with + | [ v ] -> + st :: + [S.if_ arg [S.exp (E.assign (E.dot var_v label) + (match new_eff with + | [] -> v + | x :: xs -> + E.seq (E.fuse_to_seq x xs) v + )) ]] + | _ -> assert false + end end | _ -> assert false )