From 1df597593f768165f7ec7f014c5b6f0d1caa3e64 Mon Sep 17 00:00:00 2001 From: mununki Date: Wed, 4 Nov 2026 14:19:42 +0900 Subject: [PATCH] Evaluate a polymorphic variant argument of an external once, in place MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why: The translation of a polymorphic variant argument of an external read an argument other than a literal twice, as `arg.NAME` and `arg.VAL` of an event-style `@string`, or inside the arrow function that switches on it for `@int` and `@as`. So `on(t, next())` called `next()` twice, and an `await` in the argument was a syntax error in the arrow function. The functions in `Js_of_lam_variant` return an expression and cannot bind the argument, so `Lam_compile` now binds it to a temporary among the statements of the call's arguments, unless reading it twice or in the function is the same as reading it once. JS modified (polymorphic variant argument): Example: type t @send external on: (t, @string [#click(int => unit) | #keydown(string => unit)]) => unit = "on" @send external setLevel: (t, @int [#low | #high]) => unit = "setLevel" let f = (t, next) => on(t, next()) let g = async (t, p) => setLevel(t, await p) Before (js): `g` is a SyntaxError when the module loads function f(t, next) { t.on(next().NAME, next().VAL); } async function g(t, p) { t.setLevel((() => { switch (await p) { … } })()); } After (js): function f(t, next) { let tmp = next(); t.on(tmp.NAME, tmp.VAL); } async function g(t, p) { let tmp = await p; t.setLevel((() => { switch (tmp) { … } })()); } JS modified (literal with a payload): Example: type t @send external on: (t, @string [#click(int => unit) | #keydown(string => unit)]) => unit = "on" @val external wrap: (int => unit) => int => unit = "wrap" let l = (t, handler) => on(t, #click(wrap(handler))) Before (js): function l(t, handler) { t.on(({ NAME: "click", VAL: wrap(handler) }).NAME, ({ NAME: "click", VAL: wrap(handler) }).VAL); } After (js): function l(t, handler) { t.on("click", wrap(handler)); } JS modified (while condition with statements): Example: type t @send external has: (t, @string [#click(int => unit) | #keydown(string => unit)]) => bool = "has" let w = async (t, p) => { let n = ref(0) while has(t, await p) { n := n.contents + 1 } n.contents } Before (js): async function w(t, p) { let n = 0; while (t.has((await p).NAME, (await p).VAL)) { n = n + 1 | 0; }; return n; } After (js): async function w(t, p) { let n = 0; while (true) { let tmp = await p; if (!t.has(tmp.NAME, tmp.VAL)) { break; } n = n + 1 | 0; }; return n; } Review: Which arguments keep their output? Literals, constants and variables, and for an `@int` or `@string` dispatch, which reads the argument once, any argument without side effects. An event-style argument is read twice, so fields, array elements and conditionals of variables stay in place, but a `@val` global or a `@get` property read is bound, since it may run a getter. `gpr_2633_test.mjs` changes because it pinned `foo.on(h(event).NAME, h(event).VAL)`. Signed-off-by: mununki --- changes/polyvar-external-argument-once.fix.md | 1 + compiler/core/js_of_lam_variant.ml | 45 +- compiler/core/js_of_lam_variant.mli | 8 + compiler/core/lam_compile.ml | 32 +- compiler/core/lam_compile_external_call.ml | 47 ++ compiler/core/lam_compile_external_call.mli | 15 + compiler/core/lam_compile_external_obj.ml | 21 + compiler/core/lam_compile_external_obj.mli | 7 + tests/tests/src/gpr_2633_test.mjs | 3 +- tests/tests/src/gpr_2633_test.res | 2 +- tests/tests/src/polyvar_external_arg_test.mjs | 463 ++++++++++++++++++ tests/tests/src/polyvar_external_arg_test.res | 283 +++++++++++ 12 files changed, 902 insertions(+), 25 deletions(-) create mode 100644 changes/polyvar-external-argument-once.fix.md create mode 100644 tests/tests/src/polyvar_external_arg_test.mjs create mode 100644 tests/tests/src/polyvar_external_arg_test.res diff --git a/changes/polyvar-external-argument-once.fix.md b/changes/polyvar-external-argument-once.fix.md new file mode 100644 index 00000000000..01e2d360216 --- /dev/null +++ b/changes/polyvar-external-argument-once.fix.md @@ -0,0 +1 @@ +- Evaluate a polymorphic variant argument of an external once, in its place among the arguments. An event-style `@string` argument such as `on(t, mk())` ran `mk()` twice, and an `await` in an `@int` argument, or in a `@string` argument with `@as`, was put in a generated function, which is a syntax error. diff --git a/compiler/core/js_of_lam_variant.ml b/compiler/core/js_of_lam_variant.ml index 5d6c27c1f12..43861209824 100644 --- a/compiler/core/js_of_lam_variant.ml +++ b/compiler/core/js_of_lam_variant.ml @@ -27,6 +27,34 @@ module S = Js_stmt_make type arg_expression = Splice0 | Splice1 of E.t | Splice2 of E.t * E.t +(* [eval] and [eval_as_int] read an argument other than a literal once, + inside the function that dispatches on it. That is the same as reading it + in place when the read has no effect and cannot await. *) +let eval_in_place (arg : J.expression) = + Js_analyzer.no_side_effect_expression arg + +(* [eval_as_event] reads an argument other than a literal twice, for the tag + (inside the function that dispatches on it, with [@as]) and for the + payload. That is the same as reading it once, in place, for constants, + variables, and fields, array elements and conditionals of them. A JS global + ([@val]) or a JS property read, as from a [@get] external, may run a getter + each time, so it does not count. *) +let eval_as_event_in_place (arg : J.expression) = + let rec duplicable (e : J.expression) = + match e.expression_desc with + | Undefined _ | Bool _ | Number _ | Str _ | Template_literal _ + | Var (Qualified _) -> + true + | Var (Id id) -> not (Ext_ident.is_js id) + | Static_index (e, _, Some _) -> duplicable e + | Array_index (a, b) -> duplicable a && duplicable b + | Cond (a, b, c) -> duplicable a && duplicable b && duplicable c + | _ -> false + in + match arg.expression_desc with + | Caml_block ([{expression_desc = Str _}; _], _, Blk_poly_var) -> true + | _ -> duplicable arg + (* we need destruct [undefined] when input is optional *) let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = if arg == E.undefined then E.undefined @@ -54,18 +82,13 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = (* invariant: optional is not allowed in this case *) (* arg is a polyvar *) -(** FIXME: - 1. duplicated evaluation of expressions arg - Solution: calcuate the arg once in the beginning - 2. avoid block for branches < 3 - or always? - a === 444? "a" : a==222? "b" -*) +(** A literal passes its tag and its payload, evaluated in place. Any other + [arg] is read twice, for the tag and for the payload, so the caller binds + it to a variable first unless it is [eval_as_event_in_place]. *) let eval_as_event (arg : J.expression) (dispatches : (string * string) list option) = match arg.expression_desc with - | Caml_block ([{expression_desc = Str txt}; cb], _, Blk_poly_var) - when Js_analyzer.no_side_effect_expression cb -> + | Caml_block ([{expression_desc = Str txt}; cb], _, Blk_poly_var) -> let v = match dispatches with | Some dispatches -> Ext_list.assoc_by_string dispatches txt None @@ -92,10 +115,6 @@ let eval_as_event (arg : J.expression) } ))); ] | None -> E.poly_var_tag_access arg), - (* TODO: improve, one dispatch later, - the problem is that we can not create bindings - due to the - *) E.poly_var_value_access arg ) (* we need destruct [undefined] when input is optional *) diff --git a/compiler/core/js_of_lam_variant.mli b/compiler/core/js_of_lam_variant.mli index 61b122c7fa8..47f3cf76736 100644 --- a/compiler/core/js_of_lam_variant.mli +++ b/compiler/core/js_of_lam_variant.mli @@ -29,6 +29,14 @@ type arg_expression = | Splice1 of J.expression | Splice2 of J.expression * J.expression +val eval_in_place : J.expression -> bool +(** Whether [eval] and [eval_as_int] can be given the argument as it is, + rather than a variable bound to it: they may read it inside a function *) + +val eval_as_event_in_place : J.expression -> bool +(** Whether [eval_as_event] can be given the argument as it is, rather than a + variable bound to it: it may read it twice *) + val eval : J.expression -> (string * string) list -> J.expression val eval_as_event : diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 13ce1db96de..f4841957cba 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1776,21 +1776,25 @@ let compile output_prefix = ~info:(call_info_of_apply lambda_cxt.meta appinfo) fn_code args))) (* Compiles the arguments of a call or a literal, which are evaluated left to - right; see [sequence_arguments]. *) - and compile_arguments ?method_callee (lambda_cxt : Lam_compile_context.t) - (args : Lambda.t list) : J.block * J.expression list = + right; see [sequence_arguments]. [hold] may add statements to the + compiled arguments, such as the bindings of + [Lam_compile_external_call.hold_args]. *) + and compile_arguments ?method_callee ?(hold = Fun.id) + (lambda_cxt : Lam_compile_context.t) (args : Lambda.t list) : + J.block * J.expression list = if args = [] then ([], []) else let arg_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in sequence_arguments ?method_callee ~assignable:lambda_cxt.meta.assignable - (Ext_list.map args (fun arg -> - match compile_lambda arg_cxt arg with - | {block; value = Some value} -> (block, value) - | {value = None} -> assert false)) + (hold + (Ext_list.map args (fun arg -> + match compile_lambda arg_cxt arg with + | {block; value = Some value} -> (block, value) + | {value = None} -> assert false))) and compile_prim (prim_info : Lambda.prim_info) (lambda_cxt : Lam_compile_context.t) = - let compile_primitive_default primitive args loc = - let args_code, args_expr = compile_arguments lambda_cxt args in + let compile_primitive_default ?hold primitive args loc = + let args_code, args_expr = compile_arguments ?hold lambda_cxt args in let exp = (* TODO: all can be done in [Lam_compile_primitive.translate] *) Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive @@ -1902,13 +1906,21 @@ let compile output_prefix = body)))) | _ -> assert false) | {primitive = Pjs_object_create labels; args} -> - let args_code, args_expr = compile_arguments lambda_cxt args in + let args_code, args_expr = + compile_arguments + ~hold:(Lam_compile_external_obj.hold_obj_args labels) + lambda_cxt args + in let block, exp = Lam_compile_external_obj.assemble_obj_args labels args_expr in Js_output.output_of_block_and_expression lambda_cxt.continuation (Ext_list.append args_code block) exp + | {primitive = Pjs_call {arg_types} as primitive; args; loc} -> + compile_primitive_default + ~hold:(Lam_compile_external_call.hold_args arg_types) + primitive args loc | {primitive; args; loc} -> compile_primitive_default primitive args loc and collect_dup_overrides (copy_id : Ident.t) (lam : Lambda.t) (acc : (Lambda.set_field_dbg_info * Lambda.t) list) : diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index b2f01a8fc29..1a63ba8642e 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -25,6 +25,7 @@ [@@@warning "+9"] module E = Js_exp_make +module S = Js_stmt_make let external_var ({bundle; module_bind_name; import_attributes} : @@ -114,6 +115,52 @@ let ocaml_to_js_eff ~(arg_label : External_arg_spec.label_noname) (Splice1 single_arg, []) | Nothing -> (Splice1 arg, []) +(* The translation of a polymorphic variant argument other than a literal + reads it twice, as [e.NAME] and [e.VAL], or inside the function that a + dispatch on its tag builds, where an [await] is a syntax error. So unless + the translation can read it in place, the argument is bound to a temporary + after its statements, which keeps it in its place among the arguments (see + [sequence_arguments] in [Lam_compile]). Of an optional argument known to be + present, only the payload is bound, so that the translation still knows it + is present. *) +let hold_arg ~(arg_label : External_arg_spec.label_noname) + ~(arg_type : External_arg_spec.attr) + ((block, arg) as compiled : J.block * E.t) : J.block * E.t = + let needs_temporary (e : E.t) = + match arg_type with + | Poly_var _ -> not (Js_of_lam_variant.eval_as_event_in_place e) + | Poly_var_string _ | Int _ -> not (Js_of_lam_variant.eval_in_place e) + | Arg_cst _ | Extern_unit | Nothing | Ignore | Unwrap -> false + in + let hold (e : E.t) = + let tmp = Ext_ident.create_tmp () in + (Ext_list.append_one block (S.define_variable ~kind:Strict tmp e), E.var tmp) + in + match (arg_label, arg.expression_desc) with + | Arg_optional, Optional_block (x, identity) -> + if needs_temporary x then + let block, x = hold x in + (block, {arg with expression_desc = Optional_block (x, identity)}) + else compiled + | (Arg_optional | Arg_label | Arg_empty), _ -> + if needs_temporary arg then hold arg else compiled + +(* [hold_arg] for the compiled arguments of a call, which have the + statements that run before their values are read. The specs pair with the + arguments as in [assemble_args_no_splice], and no spec translates an + argument past them. *) +let hold_args (arg_types : External_arg_spec.params) + (args : (J.block * E.t) list) = + let rec aux (arg_types : External_arg_spec.params) args = + match (arg_types, args) with + | {arg_type = Arg_cst _; _} :: arg_types, args -> aux arg_types args + | {arg_label; arg_type} :: arg_types, arg :: args -> + hold_arg ~arg_label ~arg_type arg :: aux arg_types args + | [], args -> args + | _ :: _, [] -> assert false + in + aux arg_types args + let empty_pair = ([], []) let add_eff eff e = diff --git a/compiler/core/lam_compile_external_call.mli b/compiler/core/lam_compile_external_call.mli index 5a9e2541911..2b73daa2168 100644 --- a/compiler/core/lam_compile_external_call.mli +++ b/compiler/core/lam_compile_external_call.mli @@ -29,6 +29,21 @@ val ocaml_to_js_eff : Js_of_lam_variant.arg_expression * J.expression list (** Compile ocaml external function call to JS IR. *) +val hold_arg : + arg_label:External_arg_spec.label_noname -> + arg_type:External_arg_spec.attr -> + J.block * J.expression -> + J.block * J.expression +(** Binds a compiled argument, after its statements, to a temporary unless + [ocaml_to_js_eff] can read it in place: it reads a polymorphic variant + argument twice, or inside a function it builds *) + +val hold_args : + External_arg_spec.params -> + (J.block * J.expression) list -> + (J.block * J.expression) list +(** [hold_arg] for the compiled arguments of a call to an external *) + val translate_ffi : Lam_compile_context.t -> External_arg_spec.params -> diff --git a/compiler/core/lam_compile_external_obj.ml b/compiler/core/lam_compile_external_obj.ml index 1a981d1bf4a..ebb97c50c85 100644 --- a/compiler/core/lam_compile_external_obj.ml +++ b/compiler/core/lam_compile_external_obj.ml @@ -36,6 +36,27 @@ module S = Js_stmt_make But the default to be undefined seems reasonable *) +(* [Lam_compile_external_call.hold_arg] for the compiled arguments of an + object-creating external, which pair with the labels as in + [assemble_obj_args] *) +let rec hold_obj_args (labels : External_arg_spec.obj_params) + (args : (J.block * J.expression) list) = + match (labels, args) with + | {obj_arg_label = Obj_label _; obj_arg_type = Arg_cst _} :: labels, args -> + hold_obj_args labels args + | {obj_arg_label = Obj_empty} :: labels, arg :: args -> + arg :: hold_obj_args labels args + | {obj_arg_label = Obj_label _; obj_arg_type} :: labels, arg :: args -> + Lam_compile_external_call.hold_arg ~arg_label:Arg_label + ~arg_type:obj_arg_type arg + :: hold_obj_args labels args + | {obj_arg_label = Obj_optional _; obj_arg_type} :: labels, arg :: args -> + Lam_compile_external_call.hold_arg ~arg_label:Arg_optional + ~arg_type:obj_arg_type arg + :: hold_obj_args labels args + | [], [] -> [] + | [], _ :: _ | _ :: _, [] -> assert false + (* TODO: check stackoverflow *) let assemble_obj_args (labels : External_arg_spec.obj_params) (args : J.expression list) : J.block * J.expression = diff --git a/compiler/core/lam_compile_external_obj.mli b/compiler/core/lam_compile_external_obj.mli index 02d944f5c5c..22ef0262938 100644 --- a/compiler/core/lam_compile_external_obj.mli +++ b/compiler/core/lam_compile_external_obj.mli @@ -25,6 +25,13 @@ (** Compiles the labelled arguments of an object-creating external to a JS object literal. *) +val hold_obj_args : + External_arg_spec.obj_params -> + (J.block * J.expression) list -> + (J.block * J.expression) list +(** {!Lam_compile_external_call.hold_arg} for the compiled arguments of an + object-creating external *) + val assemble_obj_args : External_arg_spec.obj_params -> J.expression list -> J.block * J.expression (* It returns a block in cases we need set the property dynamically: we need diff --git a/tests/tests/src/gpr_2633_test.mjs b/tests/tests/src/gpr_2633_test.mjs index 8d22cca8655..d10f42e9dd7 100644 --- a/tests/tests/src/gpr_2633_test.mjs +++ b/tests/tests/src/gpr_2633_test.mjs @@ -6,7 +6,8 @@ function on1(foo, event) { } function on2(foo, h, event) { - foo.on(h(event).NAME, h(event).VAL); + let tmp = h(event); + foo.on(tmp.NAME, tmp.VAL); } export { diff --git a/tests/tests/src/gpr_2633_test.res b/tests/tests/src/gpr_2633_test.res index 74959dc2fcd..24fa4a3a14e 100644 --- a/tests/tests/src/gpr_2633_test.res +++ b/tests/tests/src/gpr_2633_test.res @@ -12,5 +12,5 @@ external on: ( let on1 = (foo, event) => on(foo, event) -/* FIXME */ +// h(event) is evaluated once let on2 = (foo, h, event) => on(foo, h(event)) diff --git a/tests/tests/src/polyvar_external_arg_test.mjs b/tests/tests/src/polyvar_external_arg_test.mjs new file mode 100644 index 00000000000..4990ffe2608 --- /dev/null +++ b/tests/tests/src/polyvar_external_arg_test.mjs @@ -0,0 +1,463 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; +import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.mjs"; + +let makeTarget = (() => { + const calls = [] + const record = (...args) => { + calls.push(args.map(a => typeof a === "function" ? a(1) : String(a)).join(" ")) + } + const has = (...args) => { + record(...args) + return args[0] === "click" + } + return { calls, has, on: record, onAfter: record, onBefore: record, setMode: record, setLevel: record, setLevelOpt: record } +}); + +let makeSource = (() => ({ + reads: 0, + get current() { + this.reads++ + return { NAME: "keydown", VAL: x => "keydown " + x } + } +})); + +let defineGlobalEvent = (() => { + let reads = 0 + Object.defineProperty(globalThis, "polyvarExternalArgEvent", { + configurable: true, + get() { + reads++ + return { NAME: "click", VAL: x => "click " + x } + } + }) + return () => reads +}); + +let opaque = (x => x); + +function click(x) { + return "click " + x.toString(); +} + +function keydown(x) { + return "keydown " + x.toString(); +} + +let lastEvent = { + contents: opaque({ + NAME: "keydown", + VAL: keydown + }) +}; + +Mocha.describe("Polyvar_external_arg_test", () => { + Mocha.test("an event-style argument with side effects", () => { + let t = makeTarget(); + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + let tmp = mark("event", opaque({ + NAME: "keydown", + VAL: keydown + })); + t.on(tmp.NAME, tmp.VAL); + let tmp$1 = mark("dispatch", opaque({ + NAME: "click", + VAL: click + })); + t.on((() => { + switch (tmp$1.NAME) { + case "click" : + return "click!"; + case "keydown" : + return "keydown!"; + } + })(), tmp$1.VAL); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 121, characters 7-14", [ + "event", + "dispatch" + ], log); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 122, characters 7-14", [ + "keydown keydown 1", + "click! click 1" + ], t.calls); + }); + Mocha.test("a literal event with a payload that has side effects", () => { + let t = makeTarget(); + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + t.on("click", mark("payload", click)); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 133, characters 7-14", ["payload"], log); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 134, characters 7-14", ["click click 1"], t.calls); + }); + Mocha.test("@string and @int arguments with side effects in temporaries", () => { + let t = makeTarget(); + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + let tmp = mark("mode", opaque("dark")); + t.setMode((() => { + switch (tmp) { + case "light" : + return "light-mode"; + case "dark" : + return "dark-mode"; + } + })()); + let tmp$1 = mark("level", opaque("high")); + t.setLevel((() => { + switch (tmp$1) { + case "low" : + return 0; + case "high" : + return 10; + } + })()); + let tmp$2 = mark("optional", opaque("low")); + t.setLevelOpt((() => { + switch (tmp$2 !== undefined ? Primitive_option.valFromOption(tmp$2) : undefined) { + case "low" : + return 0; + case "high" : + return 10; + } + })()); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 147, characters 7-14", [ + "mode", + "level", + "optional" + ], log); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 148, characters 7-14", [ + "dark-mode", + "10", + "0" + ], t.calls); + }); + Mocha.test("the arguments around an event-style argument run in order", () => { + let t = makeTarget(); + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + let tmp = mark("first", "a"); + let tmp$1 = mark("second", opaque({ + NAME: "click", + VAL: click + })); + t.onAfter(tmp, tmp$1.NAME, tmp$1.VAL); + let tmp$2 = mark("third", opaque({ + NAME: "keydown", + VAL: keydown + })); + t.onBefore(tmp$2.NAME, tmp$2.VAL, mark("fourth", "b")); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 160, characters 7-14", [ + "first", + "second", + "third", + "fourth" + ], log); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 161, characters 7-14", [ + "a click click 1", + "keydown keydown 1 b" + ], t.calls); + }); + Mocha.test("getters read as event-style arguments", () => { + let t = makeTarget(); + let s = makeSource(); + let tmp = s.current; + t.on(tmp.NAME, tmp.VAL); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 168, characters 7-14", 1, s.reads); + let globalReads = defineGlobalEvent(); + let tmp$1 = polyvarExternalArgEvent; + t.on(tmp$1.NAME, tmp$1.VAL); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 171, characters 7-14", 1, globalReads()); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 172, characters 7-14", [ + "keydown keydown 1", + "click click 1" + ], t.calls); + }); + Mocha.test("refs read as event-style arguments", () => { + let t = makeTarget(); + let r = opaque({ + NAME: "click", + VAL: click + }); + t.on(r.NAME, r.VAL); + r = opaque({ + NAME: "keydown", + VAL: keydown + }); + t.on((() => { + switch (r.NAME) { + case "click" : + return "click!"; + case "keydown" : + return "keydown!"; + } + })(), r.VAL); + t.on(lastEvent.contents.NAME, lastEvent.contents.VAL); + lastEvent.contents = opaque({ + NAME: "click", + VAL: click + }); + t.on((() => { + switch (lastEvent.contents.NAME) { + case "click" : + return "click!"; + case "keydown" : + return "keydown!"; + } + })(), lastEvent.contents.VAL); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 185, characters 6-13", [ + "click click 1", + "keydown! keydown 1", + "keydown keydown 1", + "click! click 1" + ], t.calls); + }); + Mocha.test("awaited arguments", async () => { + let t = makeTarget(); + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + let tmp = await mark("event", Promise.resolve(opaque({ + NAME: "keydown", + VAL: keydown + }))); + t.on(tmp.NAME, tmp.VAL); + let tmp$1 = await mark("dispatch", Promise.resolve(opaque({ + NAME: "click", + VAL: click + }))); + t.on((() => { + switch (tmp$1.NAME) { + case "click" : + return "click!"; + case "keydown" : + return "keydown!"; + } + })(), tmp$1.VAL); + let tmp$2 = await mark("mode", Promise.resolve(opaque("light"))); + t.setMode((() => { + switch (tmp$2) { + case "light" : + return "light-mode"; + case "dark" : + return "dark-mode"; + } + })()); + let tmp$3 = await mark("level", Promise.resolve(opaque("high"))); + t.setLevel((() => { + switch (tmp$3) { + case "low" : + return 0; + case "high" : + return 10; + } + })()); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 202, characters 7-14", [ + "event", + "dispatch", + "mode", + "level" + ], log); + return Test_utils.eq("File \"polyvar_external_arg_test.res\", line 203, characters 7-14", [ + "keydown keydown 1", + "click! click 1", + "light-mode", + "10" + ], t.calls); + }); + Mocha.test("a while condition with a temporary, and break and continue", () => { + let t = makeTarget(); + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + let i = 0; + let seen = []; + loop_0: while (i < 4) { + i = i + 1 | 0; + let j = 0; + while (true) { + if (i === 3) { + break loop_0; + } + j = j + 1 | 0; + let tmp = false; + if (j <= i) { + let tmp$1 = mark("event", opaque({ + NAME: "click", + VAL: click + })); + tmp = t.has(tmp$1.NAME, tmp$1.VAL); + } + if (!tmp) { + break; + } + if (j === 2) { + continue; + } + seen.push([ + i, + j + ]); + }; + }; + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 231, characters 7-14", 3, i); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 232, characters 7-14", [ + [ + 1, + 1 + ], + [ + 2, + 1 + ] + ], seen); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 233, characters 7-14", [ + "event", + "event", + "event" + ], log); + }); + Mocha.test("arguments in a while condition that awaits", async () => { + let t = makeTarget(); + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + let n = 0; + while (true) { + let tmp = false; + if (n < 3) { + let tmp$1 = await mark("event", Promise.resolve(opaque({ + NAME: "click", + VAL: click + }))); + tmp = t.has(tmp$1.NAME, tmp$1.VAL); + } + if (!tmp) { + break; + } + n = n + 1 | 0; + }; + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 247, characters 7-14", 3, n); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 248, characters 7-14", [ + "event", + "event", + "event" + ], log); + let events = [ + opaque({ + NAME: "click", + VAL: click + }), + opaque({ + NAME: "keydown", + VAL: keydown + }) + ]; + let i = 0; + while (await Promise.resolve(true) && i < events.length && t.has(events[i].NAME, events[i].VAL)) { + i = i + 1 | 0; + }; + return Test_utils.eq("File \"polyvar_external_arg_test.res\", line 260, characters 7-14", 1, i); + }); + Mocha.test("awaited fields of an object-creating external", async () => { + let log = []; + let mark = (s, v) => { + log.push(s); + return v; + }; + let tmp = await mark("level", Promise.resolve(opaque("high"))); + let tmp$1 = await mark("mode", Promise.resolve(opaque("dark"))); + let options = { + level: (() => { + switch (tmp) { + case "low" : + return 0; + case "high" : + return 10; + } + })(), + mode: (() => { + switch (tmp$1) { + case "light" : + return "light-mode"; + case "dark" : + return "dark-mode"; + } + })() + }; + let tmp$2 = await mark("level", Promise.resolve(opaque("low"))); + let tmp$3 = await mark("mode", Promise.resolve(opaque("light"))); + let tmp$4 = { + level: (() => { + switch (tmp$2) { + case "low" : + return 0; + case "high" : + return 10; + } + })() + }; + if (tmp$3 !== undefined) { + tmp$4.mode = (() => { + switch (tmp$3) { + case "light" : + return "light-mode"; + case "dark" : + return "dark-mode"; + } + })(); + } + let optional = tmp$4; + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 279, characters 7-14", [ + "level", + "mode", + "level", + "mode" + ], log); + Test_utils.eq("File \"polyvar_external_arg_test.res\", line 280, characters 7-14", [ + 10, + "dark-mode" + ], [ + options.level, + options.mode + ]); + return Test_utils.eq("File \"polyvar_external_arg_test.res\", line 281, characters 7-14", [ + 0, + "light-mode" + ], [ + optional.level, + optional.mode + ]); + }); +}); + +export { + makeTarget, + makeSource, + defineGlobalEvent, + opaque, + click, + keydown, + lastEvent, +} +/* lastEvent Not a pure module */ diff --git a/tests/tests/src/polyvar_external_arg_test.res b/tests/tests/src/polyvar_external_arg_test.res new file mode 100644 index 00000000000..cb57b3e50b4 --- /dev/null +++ b/tests/tests/src/polyvar_external_arg_test.res @@ -0,0 +1,283 @@ +open Mocha +open Test_utils + +@module("mocha") +external testAsync: (string, unit => promise) => unit = "test" + +// A polymorphic variant argument of an external is evaluated once, in its +// place among the arguments, and not inside a function the compiler creates. +// An event-style argument is passed as its tag and its payload, and an @as or +// @int dispatch switches on the argument in a function, so an argument with +// side effects is read from a temporary, as is a getter passed as an +// event-style argument. In a while condition, the temporary is bound inside +// the loop. + +type target + +let makeTarget: unit => target = %raw(`() => { + const calls = [] + const record = (...args) => { + calls.push(args.map(a => typeof a === "function" ? a(1) : String(a)).join(" ")) + } + const has = (...args) => { + record(...args) + return args[0] === "click" + } + return { calls, has, on: record, onAfter: record, onBefore: record, setMode: record, setLevel: record, setLevelOpt: record } +}`) + +@get external calls: target => array = "calls" + +@send +external on: (target, @string [#click(int => string) | #keydown(int => string)]) => unit = "on" + +@send +external has: (target, @string [#click(int => string) | #keydown(int => string)]) => bool = "has" + +@send +external onAs: ( + target, + @string [@as("click!") #click(int => string) | @as("keydown!") #keydown(int => string)], +) => unit = "on" + +@send +external setMode: (target, @string [@as("light-mode") #light | @as("dark-mode") #dark]) => unit = + "setMode" + +@send external setLevel: (target, @int [#low | @as(10) #high]) => unit = "setLevel" + +@send +external setLevelOpt: (target, ~level: @int [#low | @as(10) #high]=?, unit) => unit = "setLevelOpt" + +@send +external onAfter: ( + target, + string, + @string [#click(int => string) | #keydown(int => string)], +) => unit = "onAfter" + +@send +external onBefore: ( + target, + @string [#click(int => string) | #keydown(int => string)], + string, +) => unit = "onBefore" + +@obj +external makeOptions: ( + ~level: @int [#low | @as(10) #high], + ~mode: @string [@as("light-mode") #light | @as("dark-mode") #dark]=?, + unit, +) => _ = "" + +type source + +let makeSource: unit => source = %raw(`() => ({ + reads: 0, + get current() { + this.reads++ + return { NAME: "keydown", VAL: x => "keydown " + x } + } +})`) + +@get external current: source => [#click(int => string) | #keydown(int => string)] = "current" +@get external reads: source => int = "reads" + +@val +external globalEvent: [#click(int => string) | #keydown(int => string)] = "polyvarExternalArgEvent" + +let defineGlobalEvent: unit => unit => int = %raw(`() => { + let reads = 0 + Object.defineProperty(globalThis, "polyvarExternalArgEvent", { + configurable: true, + get() { + reads++ + return { NAME: "click", VAL: x => "click " + x } + } + }) + return () => reads +}`) + +// Opaque, so that the optimizer cannot tell the argument is a literal. +let opaque: 'a => 'a = %raw(`x => x`) + +external toOption: undefined => option = "%identity" + +let click = x => "click " ++ Int.toString(x) +let keydown = x => "keydown " ++ Int.toString(x) + +let lastEvent = ref(opaque(#keydown(keydown))) + +describe(__MODULE__, () => { + test("an event-style argument with side effects", () => { + let t = makeTarget() + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + on(t, mark("event", opaque(#keydown(keydown)))) + onAs(t, mark("dispatch", opaque(#click(click)))) + eq(__LOC__, ["event", "dispatch"], log) + eq(__LOC__, ["keydown keydown 1", "click! click 1"], calls(t)) + }) + + test("a literal event with a payload that has side effects", () => { + let t = makeTarget() + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + on(t, #click(mark("payload", click))) + eq(__LOC__, ["payload"], log) + eq(__LOC__, ["click click 1"], calls(t)) + }) + + test("@string and @int arguments with side effects in temporaries", () => { + let t = makeTarget() + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + setMode(t, mark("mode", opaque(#dark))) + setLevel(t, mark("level", opaque(#high))) + setLevelOpt(t, ~level=?mark("optional", opaque(Some(#low))), ()) + eq(__LOC__, ["mode", "level", "optional"], log) + eq(__LOC__, ["dark-mode", "10", "0"], calls(t)) + }) + + test("the arguments around an event-style argument run in order", () => { + let t = makeTarget() + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + onAfter(t, mark("first", "a"), mark("second", opaque(#click(click)))) + onBefore(t, mark("third", opaque(#keydown(keydown))), mark("fourth", "b")) + eq(__LOC__, ["first", "second", "third", "fourth"], log) + eq(__LOC__, ["a click click 1", "keydown keydown 1 b"], calls(t)) + }) + + test("getters read as event-style arguments", () => { + let t = makeTarget() + let s = makeSource() + on(t, current(s)) + eq(__LOC__, 1, reads(s)) + let globalReads = defineGlobalEvent() + on(t, globalEvent) + eq(__LOC__, 1, globalReads()) + eq(__LOC__, ["keydown keydown 1", "click click 1"], calls(t)) + }) + + test("refs read as event-style arguments", () => { + let t = makeTarget() + let r = ref(opaque(#click(click))) + on(t, r.contents) + r := opaque(#keydown(keydown)) + onAs(t, r.contents) + on(t, lastEvent.contents) + lastEvent := opaque(#click(click)) + onAs(t, lastEvent.contents) + eq( + __LOC__, + ["click click 1", "keydown! keydown 1", "keydown keydown 1", "click! click 1"], + calls(t), + ) + }) + + testAsync("awaited arguments", async () => { + let t = makeTarget() + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + on(t, await mark("event", Promise.resolve(opaque(#keydown(keydown))))) + onAs(t, await mark("dispatch", Promise.resolve(opaque(#click(click))))) + setMode(t, await mark("mode", Promise.resolve(opaque(#light)))) + setLevel(t, await mark("level", Promise.resolve(opaque(#high)))) + eq(__LOC__, ["event", "dispatch", "mode", "level"], log) + eq(__LOC__, ["keydown keydown 1", "click! click 1", "light-mode", "10"], calls(t)) + }) + + test("a while condition with a temporary, and break and continue", () => { + let t = makeTarget() + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + let i = ref(0) + let seen = [] + while i.contents < 4 { + i := i.contents + 1 + let j = ref(0) + while { + if i.contents == 3 { + break + } + j := j.contents + 1 + j.contents <= i.contents && has(t, mark("event", opaque(#click(click)))) + } { + if j.contents == 2 { + continue + } + seen->Array.push((i.contents, j.contents)) + } + } + eq(__LOC__, 3, i.contents) + eq(__LOC__, [(1, 1), (2, 1)], seen) + eq(__LOC__, ["event", "event", "event"], log) + }) + + testAsync("arguments in a while condition that awaits", async () => { + let t = makeTarget() + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + let n = ref(0) + while n.contents < 3 && has(t, await mark("event", Promise.resolve(opaque(#click(click))))) { + n := n.contents + 1 + } + eq(__LOC__, 3, n.contents) + eq(__LOC__, ["event", "event", "event"], log) + + // An argument without side effects stays in the condition + let events = [opaque(#click(click)), opaque(#keydown(keydown))] + let i = ref(0) + while ( + (await Promise.resolve(true)) && + i.contents < Array.length(events) && + has(t, events->Array.getUnsafe(i.contents)) + ) { + i := i.contents + 1 + } + eq(__LOC__, 1, i.contents) + }) + + testAsync("awaited fields of an object-creating external", async () => { + let log = [] + let mark = (s, v) => { + log->Array.push(s) + v + } + let options = makeOptions( + ~level=await mark("level", Promise.resolve(opaque(#high))), + ~mode=await mark("mode", Promise.resolve(opaque(#dark))), + (), + ) + let optional = makeOptions( + ~level=await mark("level", Promise.resolve(opaque(#low))), + ~mode=?await mark("mode", Promise.resolve(opaque(Some(#light)))), + (), + ) + eq(__LOC__, ["level", "mode", "level", "mode"], log) + eq(__LOC__, (10, Some("dark-mode")), (options["level"], options["mode"]->toOption)) + eq(__LOC__, (0, Some("light-mode")), (optional["level"], optional["mode"]->toOption)) + }) +})