host/tests: Phase 0 — relate→delete row as an SX engine test (no browser)
Port the relate-picker's relate-delete behaviour from Playwright into an SX harness test that drives the real engine (web/engine.sx + web/orchestration.sx) against the OCaml runner's in-memory mock DOM. Builds the candidate row, runs process-elements to bind the form's submit, mocks fetch-request to return the host's empty 200, fires submit, and asserts the row is deleted in place — the full fetch→swap→DOM-mutation loop in pure SX. Mock-DOM completeness (run_tests.ml): NodeList.item(i) so dom-query-all can iterate querySelectorAll results, and a DOMParser mock so the empty-body sx-swap=delete path (handle-html-response → parseFromString) works as in a browser. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -2961,6 +2961,15 @@ let run_spec_tests env test_files =
|
||||
| "setTimeout" -> (match rest with fn :: _ -> ignore (Sx_ref.cek_call fn (List [])); Nil | _ -> Nil)
|
||||
| "clearTimeout" -> Nil
|
||||
| _ -> Nil)
|
||||
(* NodeList.item(i) — dom-query-all iterates the querySelectorAll result
|
||||
(a bare List) via this method, exactly like a browser NodeList. *)
|
||||
| (List _ | ListRef _) :: String "item" :: [idx] ->
|
||||
let items = match args with
|
||||
| List l :: _ -> l
|
||||
| ListRef { contents = l } :: _ -> l
|
||||
| _ -> [] in
|
||||
let i = match idx with Number n -> int_of_float n | Integer n -> n | _ -> -1 in
|
||||
if i >= 0 && i < List.length items then List.nth items i else Nil
|
||||
| Dict d :: String "hasOwnProperty" :: [String k] ->
|
||||
Bool (Hashtbl.mem d k)
|
||||
| Dict d :: String m :: rest ->
|
||||
@@ -3070,6 +3079,26 @@ let run_spec_tests env test_files =
|
||||
(* console.log/debug/error — no-op in tests *)
|
||||
Nil
|
||||
|
||||
else if mt = "domparser" then
|
||||
(* DOMParser.parseFromString(text, "text/html") — returns a mock
|
||||
document whose <body> is parsed from `text`. An empty string yields
|
||||
a valid empty document (truthy), matching the browser: that's what
|
||||
the engine's handle-html-response relies on for an empty-body
|
||||
sx-swap="delete" response. *)
|
||||
(match m with
|
||||
| "parseFromString" ->
|
||||
let text = match rest with String t :: _ -> t | _ -> "" in
|
||||
let bd = match make_mock_element "body" with Dict d -> d | _ -> Hashtbl.create 0 in
|
||||
Hashtbl.replace bd "tagName" (String "BODY");
|
||||
Hashtbl.replace bd "nodeName" (String "BODY");
|
||||
parse_html_into bd text;
|
||||
Hashtbl.replace bd "innerHTML" (String text);
|
||||
let doc = Hashtbl.create 4 in
|
||||
Hashtbl.replace doc "__mock_type" (String "document");
|
||||
Hashtbl.replace doc "body" (Dict bd);
|
||||
Dict doc
|
||||
| _ -> Nil)
|
||||
|
||||
else
|
||||
(* Element methods *)
|
||||
(match m with
|
||||
@@ -3483,6 +3512,10 @@ let run_spec_tests env test_files =
|
||||
Dict ev
|
||||
| [String "Object"] ->
|
||||
Dict (Hashtbl.create 4)
|
||||
| [String "DOMParser"] ->
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "__mock_type" (String "domparser");
|
||||
Dict d
|
||||
| _ -> Nil);
|
||||
|
||||
reg "host-callback" (fun args ->
|
||||
|
||||
127
web/tests/test-relate-picker.sx
Normal file
127
web/tests/test-relate-picker.sx
Normal file
@@ -0,0 +1,127 @@
|
||||
;; SX-native engine tests for the host's relate picker (lib/host/blog.sx).
|
||||
;;
|
||||
;; These drive the REAL hypermedia engine (web/engine.sx + web/orchestration.sx)
|
||||
;; against the OCaml test harness's in-memory mock DOM — NO browser. They are the
|
||||
;; SX-native replacement for lib/host/playwright/relate-picker.spec.js: the same
|
||||
;; populate / filter / paging / relate-delete / error-retry behaviours, asserted
|
||||
;; with zero Chromium. The engine only ever talks to a *platform* (fetch, DOM ops,
|
||||
;; timers) that is injected; the harness supplies a mock platform, so the engine's
|
||||
;; fetch -> swap -> DOM-mutation loop is exercised end to end in pure SX.
|
||||
;;
|
||||
;; Pattern (mirrors test-swap-integration.sx's mock-response approach):
|
||||
;; 1. build a mock DOM by setting innerHTML on a container attached to the body
|
||||
;; 2. (process-elements root) binds the engine's triggers (form submit etc.)
|
||||
;; 3. override `fetch-request` to invoke the success/error callback with a
|
||||
;; mocked response (status, content-type, body)
|
||||
;; 4. fire the trigger (dispatch a DOM event) and assert the resulting DOM
|
||||
|
||||
;; ── mock fetch ──────────────────────────────────────────────────────
|
||||
;; The engine's do-fetch calls (fetch-request config success-fn error-fn) with
|
||||
;; success-fn signature (resp-ok status get-header text). We override it to feed a
|
||||
;; canned response synchronously — the swap path then runs exactly as in a browser.
|
||||
(define _mock-fetch-calls 0)
|
||||
(define _mock-fetch-ok true)
|
||||
(define _mock-fetch-status 200)
|
||||
(define _mock-fetch-ct "text/html; charset=utf-8")
|
||||
(define _mock-fetch-body "")
|
||||
(define _mock-fetch-fail false)
|
||||
|
||||
(define reset-fetch-mock!
|
||||
(fn ()
|
||||
(set! _mock-fetch-calls 0)
|
||||
(set! _mock-fetch-ok true)
|
||||
(set! _mock-fetch-status 200)
|
||||
(set! _mock-fetch-ct "text/html; charset=utf-8")
|
||||
(set! _mock-fetch-body "")
|
||||
(set! _mock-fetch-fail false)))
|
||||
|
||||
(define fetch-request
|
||||
(fn (config success-fn error-fn)
|
||||
(set! _mock-fetch-calls (+ _mock-fetch-calls 1))
|
||||
(if _mock-fetch-fail
|
||||
(error-fn "network error")
|
||||
(success-fn _mock-fetch-ok _mock-fetch-status
|
||||
(fn (name) (if (= name "content-type") _mock-fetch-ct nil))
|
||||
_mock-fetch-body))))
|
||||
|
||||
;; ── harness platform shims ──────────────────────────────────────────
|
||||
;; Reactive hydration + island disposal live in web/boot.sx (the browser boot
|
||||
;; module, not loaded by the test runner — it pulls the signals/adapter-dom boot
|
||||
;; chain). The picker is plain SX-htmx with no islands or reactive attrs, so every
|
||||
;; one of these is a no-op here. Defined at top level so orchestration's swap path
|
||||
;; (post-swap -> sx-hydrate -> sx-hydrate-elements, dispose-islands-in) resolves
|
||||
;; them by late binding through the global env — the same mechanism that lets the
|
||||
;; fetch-request override above take effect. With these in place post-swap runs to
|
||||
;; completion, including its final (process-elements root) that re-binds triggers
|
||||
;; on swapped-in content — which the paging tests below depend on.
|
||||
(define dispose-islands-in (fn (root) nil))
|
||||
(define sx-hydrate-elements (fn (root) nil))
|
||||
(define sx-hydrate-islands (fn (root) nil))
|
||||
(define run-post-render-hooks (fn () nil))
|
||||
|
||||
;; ── mock DOM helpers ────────────────────────────────────────────────
|
||||
;; Build a detached-then-attached subtree from an HTML string and return the
|
||||
;; container. Attaching to (dom-body) is required because resolve-target uses
|
||||
;; (dom-query "#id") which queries the document.
|
||||
(define mk-root
|
||||
(fn (html)
|
||||
(let ((container (dom-create-element "div" nil)))
|
||||
(dom-set-attr container "id" "test-root")
|
||||
(dom-append (dom-body) container)
|
||||
(dom-set-inner-html container html)
|
||||
container)))
|
||||
|
||||
;; Remove the test root from the body so tests don't leak DOM into each other.
|
||||
(define clear-root!
|
||||
(fn (container)
|
||||
(when container (dom-remove-child (dom-body) container))))
|
||||
|
||||
;; Fire a (non-bubbling) DOM event of `type` on `el`, as the browser would.
|
||||
(define fire-event!
|
||||
(fn (el type)
|
||||
(host-call el "dispatchEvent" (host-new "Event" type))))
|
||||
|
||||
;; Count candidate rows (the engine's own dom-query-all, the same call the
|
||||
;; picker uses) — asserts through the platform DOM API, not a private shape.
|
||||
(define count-rows
|
||||
(fn (container) (len (dom-query-all container "li"))))
|
||||
|
||||
;; The picker's candidate row, exactly as host/blog--picker-item renders it:
|
||||
;; an <li id="cand-KIND-SLUG"> wrapping a relate <form sx-post sx-target sx-swap=delete>.
|
||||
(define picker-row-html
|
||||
(fn (slug kind title)
|
||||
(str
|
||||
"<ul class=\"rp-results\">"
|
||||
"<li id=\"cand-" kind "-" slug "\">"
|
||||
"<form method=\"post\" action=\"/host/relate\""
|
||||
" sx-post=\"/host/relate\""
|
||||
" sx-target=\"#cand-" kind "-" slug "\""
|
||||
" sx-swap=\"delete\">"
|
||||
"<input type=\"hidden\" name=\"other\" value=\"" slug "\">"
|
||||
"<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
|
||||
"<button type=\"submit\">" title "</button>"
|
||||
"</form>"
|
||||
"</li>"
|
||||
"</ul>")))
|
||||
|
||||
;; ── Phase 0: relate -> delete row ───────────────────────────────────
|
||||
(defsuite
|
||||
"relate-picker:relate-delete"
|
||||
(deftest
|
||||
"submitting a candidate's relate form deletes just that row"
|
||||
(reset-fetch-mock!)
|
||||
;; the AJAX relate returns an empty 200 (text/html); sx-swap=delete then
|
||||
;; removes the candidate's own <li> — this is the host's real response.
|
||||
(let
|
||||
((root (mk-root (picker-row-html "item-07" "related" "Picker Item 07")))
|
||||
(results (dom-query ".rp-results"))
|
||||
(form (dom-query "form")))
|
||||
(process-elements root)
|
||||
;; one candidate row before
|
||||
(assert-equal 1 (count-rows results))
|
||||
;; submit the relate form -> execute-request -> mock fetch -> delete swap
|
||||
(fire-event! form "submit")
|
||||
;; the fetch actually ran, and the row is gone
|
||||
(assert-true (> _mock-fetch-calls 0))
|
||||
(assert-equal 0 (count-rows results))
|
||||
(clear-root! root))))
|
||||
Reference in New Issue
Block a user