Island body: letrec instead of define (fixes render-to-dom), host-object JS fns
runner.sx: Converted define forms inside island body to letrec. Multiple define forms in a let body cause render-to-dom to fall back to eval-expr for the whole body, which evaluates (div ...) as a list instead of rendering it to DOM. letrec keeps the last body expression (div) as the render target. sx_browser.ml: js_to_value now stores plain JS functions as host objects (Dict with __host_handle) instead of wrapping as NativeFn. This preserves the original JS function identity through the SX→JS round-trip, keeping _driveAsync wrappers from host-callback intact when passed to addEventListener via host-call. Remaining: IO suspension in click handler is caught as "IO suspension in non-IO context" instead of being driven by _driveAsync. The host-callback wrapper creates the right JS function, but the event dispatch path doesn't go through K.callFn. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -171,10 +171,14 @@ and js_to_value (js : Js.Unsafe.any) : value =
|
||||
if not (Js.Unsafe.equals h Js.undefined) then
|
||||
get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float)
|
||||
else
|
||||
(* Plain JS function — wrap as NativeFn *)
|
||||
NativeFn ("js-callback", fun args ->
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
js_to_value (Js.Unsafe.fun_call js (Array.map Fun.id js_args)))
|
||||
(* Plain JS function — store as host object so value_to_js
|
||||
returns the ORIGINAL JS function when passed to host-call.
|
||||
This preserves wrappers like _driveAsync that host-callback
|
||||
attaches for IO suspension handling. *)
|
||||
let id = host_put js in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "__host_handle" (Number (float_of_int id));
|
||||
Dict d
|
||||
| "object" ->
|
||||
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals h Js.undefined) then
|
||||
|
||||
@@ -7,170 +7,176 @@
|
||||
(results (signal {}))
|
||||
(running (signal false))
|
||||
(current (signal "Ready")))
|
||||
(define
|
||||
get-doc
|
||||
(fn () (host-get (dom-query "#test-iframe") "contentDocument")))
|
||||
(define
|
||||
wait-boot
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((doc (get-doc)))
|
||||
(if
|
||||
(and
|
||||
doc
|
||||
(=
|
||||
(dom-get-attr
|
||||
(host-get doc "documentElement")
|
||||
"data-sx-ready")
|
||||
"true"))
|
||||
true
|
||||
(do (hs-wait 200) (wait-boot))))))
|
||||
(define
|
||||
reload-frame
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((w (host-get (dom-query "#test-iframe") "contentWindow")))
|
||||
(host-call (host-get w "location") "reload")
|
||||
(hs-wait 1000)
|
||||
(wait-boot)
|
||||
(hs-wait 500))))
|
||||
(define
|
||||
run-action
|
||||
(fn
|
||||
(action)
|
||||
(let
|
||||
((doc (get-doc)) (type (first action)))
|
||||
(cond
|
||||
(= type :click)
|
||||
(let
|
||||
((el (host-call doc "querySelector" (nth action 1))))
|
||||
(when (nil? el) (error (str "Not found: " (nth action 1))))
|
||||
(host-call el "click"))
|
||||
(= type :fill)
|
||||
(let
|
||||
((el (host-call doc "querySelector" (nth action 1))))
|
||||
(when (nil? el) (error (str "Not found: " (nth action 1))))
|
||||
(host-call el "focus")
|
||||
(dom-set-prop el "value" (nth action 2))
|
||||
(dom-dispatch el "input" nil)
|
||||
(dom-dispatch el "change" nil))
|
||||
(= type :wait)
|
||||
(hs-wait (nth action 1))
|
||||
(= type :assert-text)
|
||||
(let
|
||||
((el (host-call doc "querySelector" (nth action 1))))
|
||||
(when (nil? el) (error (str "Not found: " (nth action 1))))
|
||||
(let
|
||||
((txt (host-get el "textContent"))
|
||||
(kw (nth action 2))
|
||||
(expected (nth action 3)))
|
||||
(when
|
||||
(and (= kw :contains) (not (contains? txt expected)))
|
||||
(error
|
||||
(str "Expected '" expected "' in '" (slice txt 0 60) "'")))
|
||||
(when
|
||||
(and (= kw :not-contains) (contains? txt expected))
|
||||
(error (str "Unexpected '" expected "'")))))
|
||||
(= type :assert-count)
|
||||
(let
|
||||
((els (host-call doc "querySelectorAll" (nth action 1))))
|
||||
(let
|
||||
((count (host-get els "length"))
|
||||
(kw (nth action 2))
|
||||
(expected (nth action 3)))
|
||||
(when
|
||||
(and (= kw :gte) (< count expected))
|
||||
(error (str "Expected >=" expected " got " count)))))
|
||||
true
|
||||
nil))))
|
||||
(define
|
||||
run-all
|
||||
(fn
|
||||
()
|
||||
(reset! running true)
|
||||
(reset! results {})
|
||||
(for-each
|
||||
(letrec
|
||||
((get-doc (fn () (host-get (dom-query "#test-iframe") "contentDocument")))
|
||||
(wait-boot
|
||||
(fn
|
||||
(test)
|
||||
()
|
||||
(let
|
||||
((name (get test :name)))
|
||||
(reset! current (str "Running: " name))
|
||||
(reset! results (assoc (deref results) name "running"))
|
||||
(reload-frame)
|
||||
(guard
|
||||
(e
|
||||
(true
|
||||
(reset! results (assoc (deref results) name "fail"))
|
||||
(console-log (str "FAIL " name ": " e))))
|
||||
(for-each run-action (get test :actions))
|
||||
(reset! results (assoc (deref results) name "pass")))))
|
||||
tests)
|
||||
(reset! running false)
|
||||
(reset! current "Done")))
|
||||
(div
|
||||
(~tw :tokens "space-y-4")
|
||||
((doc (get-doc)))
|
||||
(if
|
||||
(and
|
||||
doc
|
||||
(=
|
||||
(dom-get-attr
|
||||
(host-get doc "documentElement")
|
||||
"data-sx-ready")
|
||||
"true"))
|
||||
true
|
||||
(do (hs-wait 200) (wait-boot))))))
|
||||
(reload-frame
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((w (host-get (dom-query "#test-iframe") "contentWindow")))
|
||||
(host-call (host-get w "location") "reload")
|
||||
(hs-wait 1000)
|
||||
(wait-boot)
|
||||
(hs-wait 500))))
|
||||
(run-action
|
||||
(fn
|
||||
(action)
|
||||
(let
|
||||
((doc (get-doc)) (type (first action)))
|
||||
(cond
|
||||
(= type :click)
|
||||
(let
|
||||
((el (host-call doc "querySelector" (nth action 1))))
|
||||
(when
|
||||
(nil? el)
|
||||
(error (str "Not found: " (nth action 1))))
|
||||
(host-call el "click"))
|
||||
(= type :fill)
|
||||
(let
|
||||
((el (host-call doc "querySelector" (nth action 1))))
|
||||
(when
|
||||
(nil? el)
|
||||
(error (str "Not found: " (nth action 1))))
|
||||
(host-call el "focus")
|
||||
(dom-set-prop el "value" (nth action 2))
|
||||
(dom-dispatch el "input" nil)
|
||||
(dom-dispatch el "change" nil))
|
||||
(= type :wait)
|
||||
(hs-wait (nth action 1))
|
||||
(= type :assert-text)
|
||||
(let
|
||||
((el (host-call doc "querySelector" (nth action 1))))
|
||||
(when
|
||||
(nil? el)
|
||||
(error (str "Not found: " (nth action 1))))
|
||||
(let
|
||||
((txt (host-get el "textContent"))
|
||||
(kw (nth action 2))
|
||||
(expected (nth action 3)))
|
||||
(when
|
||||
(and (= kw :contains) (not (contains? txt expected)))
|
||||
(error
|
||||
(str
|
||||
"Expected '"
|
||||
expected
|
||||
"' in '"
|
||||
(slice txt 0 60)
|
||||
"'")))
|
||||
(when
|
||||
(and (= kw :not-contains) (contains? txt expected))
|
||||
(error (str "Unexpected '" expected "'")))))
|
||||
(= type :assert-count)
|
||||
(let
|
||||
((els (host-call doc "querySelectorAll" (nth action 1))))
|
||||
(let
|
||||
((count (host-get els "length"))
|
||||
(kw (nth action 2))
|
||||
(expected (nth action 3)))
|
||||
(when
|
||||
(and (= kw :gte) (< count expected))
|
||||
(error (str "Expected >=" expected " got " count)))))
|
||||
true
|
||||
nil))))
|
||||
(run-all
|
||||
(fn
|
||||
()
|
||||
(reset! running true)
|
||||
(reset! results {})
|
||||
(for-each
|
||||
(fn
|
||||
(test)
|
||||
(let
|
||||
((name (get test :name)))
|
||||
(reset! current (str "Running: " name))
|
||||
(reset! results (assoc (deref results) name "running"))
|
||||
(reload-frame)
|
||||
(guard
|
||||
(e
|
||||
(true
|
||||
(reset! results (assoc (deref results) name "fail"))
|
||||
(console-log (str "FAIL " name ": " e))))
|
||||
(for-each run-action (get test :actions))
|
||||
(reset! results (assoc (deref results) name "pass")))))
|
||||
tests)
|
||||
(reset! running false)
|
||||
(reset! current "Done"))))
|
||||
(div
|
||||
(~tw :tokens "flex items-center gap-4 mb-4")
|
||||
(button
|
||||
(~tw
|
||||
:tokens "px-4 py-2 bg-violet-600 text-white rounded hover:bg-violet-700")
|
||||
:on-click (fn (e) (run-all))
|
||||
"Run All Tests")
|
||||
(span (~tw :tokens "text-sm text-stone-500") (deref current)))
|
||||
(div
|
||||
(~tw :tokens "space-y-2")
|
||||
(when
|
||||
tests
|
||||
(map
|
||||
(fn
|
||||
(test)
|
||||
(let
|
||||
((name (get test :name))
|
||||
(status (get (deref results) name)))
|
||||
(details
|
||||
(~tw :tokens "border rounded-lg overflow-hidden")
|
||||
:style (cond
|
||||
(= status "pass")
|
||||
"border-color:#bbf7d0;background:#f0fdf4"
|
||||
(= status "fail")
|
||||
"border-color:#fecaca;background:#fef2f2"
|
||||
(= status "running")
|
||||
"border-color:#c4b5fd"
|
||||
true
|
||||
"border-color:#e7e5e4")
|
||||
(summary
|
||||
(~tw
|
||||
:tokens "px-4 py-2 cursor-pointer hover:bg-stone-50 flex items-center gap-2")
|
||||
(span
|
||||
(~tw :tokens "font-bold")
|
||||
(cond
|
||||
(= status "pass")
|
||||
"✓"
|
||||
(= status "fail")
|
||||
"✗"
|
||||
(= status "running")
|
||||
"⟳"
|
||||
true
|
||||
"○"))
|
||||
(span (~tw :tokens "font-medium") name)
|
||||
(span
|
||||
(~tw :tokens "text-sm text-stone-400 ml-auto")
|
||||
(get test :desc)))
|
||||
(div
|
||||
(~tw
|
||||
:tokens "px-4 py-3 bg-stone-50 border-t border-stone-200")
|
||||
(pre
|
||||
(~tw :tokens "space-y-4")
|
||||
(div
|
||||
(~tw :tokens "flex items-center gap-4 mb-4")
|
||||
(button
|
||||
(~tw
|
||||
:tokens "px-4 py-2 bg-violet-600 text-white rounded hover:bg-violet-700")
|
||||
:on-click (fn (e) (run-all))
|
||||
"Run All Tests")
|
||||
(span (~tw :tokens "text-sm text-stone-500") (deref current)))
|
||||
(div
|
||||
(~tw :tokens "space-y-2")
|
||||
(when
|
||||
tests
|
||||
(map
|
||||
(fn
|
||||
(test)
|
||||
(let
|
||||
((name (get test :name))
|
||||
(status (get (deref results) name)))
|
||||
(details
|
||||
(~tw :tokens "border rounded-lg overflow-hidden")
|
||||
:style (cond
|
||||
(= status "pass")
|
||||
"border-color:#bbf7d0;background:#f0fdf4"
|
||||
(= status "fail")
|
||||
"border-color:#fecaca;background:#fef2f2"
|
||||
(= status "running")
|
||||
"border-color:#c4b5fd"
|
||||
true
|
||||
"border-color:#e7e5e4")
|
||||
(summary
|
||||
(~tw
|
||||
:tokens "text-xs font-mono whitespace-pre-wrap text-stone-600")
|
||||
(get test :source))))))
|
||||
tests)))
|
||||
(iframe
|
||||
:id "test-iframe"
|
||||
:src "/sx/(applications.(htmx))"
|
||||
(~tw :tokens "w-full border border-stone-200 rounded-lg mt-4")
|
||||
:style "height:600px"))))
|
||||
:tokens "px-4 py-2 cursor-pointer hover:bg-stone-50 flex items-center gap-2")
|
||||
(span
|
||||
(~tw :tokens "font-bold")
|
||||
(cond
|
||||
(= status "pass")
|
||||
"✓"
|
||||
(= status "fail")
|
||||
"✗"
|
||||
(= status "running")
|
||||
"⟳"
|
||||
true
|
||||
"○"))
|
||||
(span (~tw :tokens "font-medium") name)
|
||||
(span
|
||||
(~tw :tokens "text-sm text-stone-400 ml-auto")
|
||||
(get test :desc)))
|
||||
(div
|
||||
(~tw
|
||||
:tokens "px-4 py-3 bg-stone-50 border-t border-stone-200")
|
||||
(pre
|
||||
(~tw
|
||||
:tokens "text-xs font-mono whitespace-pre-wrap text-stone-600")
|
||||
(get test :source))))))
|
||||
tests)))
|
||||
(iframe
|
||||
:id "test-iframe"
|
||||
:src "/sx/(applications.(htmx))"
|
||||
(~tw :tokens "w-full border border-stone-200 rounded-lg mt-4")
|
||||
:style "height:600px")))))
|
||||
|
||||
;; Page component — passes test definitions to the island
|
||||
(defcomp
|
||||
|
||||
Reference in New Issue
Block a user