rose-ash/web/tests/test-relate-picker.sx

;; 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))))