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 (load / input / submit)
;;   3. override `fetch-request` to invoke the success/error callback with a
;;      mocked response (status, content-type, body) — relate-options returns
;;      HTML rows, so the body is HTML and the engine swaps via DOMParser
;;   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 "")            ;; the GET /relate-options (picker) response
(define _mock-editor-body "")           ;; the POST /relate|/unrelate (editor) response
(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-editor-body "")
    (set! _mock-fetch-fail false)))

;; URL-aware mock: the picker GETs relate-options (returns candidate rows); a relate
;; or unrelate POST returns the re-rendered editor fragment.
(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")
      (let ((url (or (get config "url") "")))
        (success-fn _mock-fetch-ok _mock-fetch-status
          (fn (name) (if (= name "content-type") _mock-fetch-ct nil))
          (if (contains? url "relate-options") _mock-fetch-body _mock-editor-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 each
;; 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 test below depends 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))

;; observe-intersection is a platform NATIVE (registered by the browser's
;; sx-platform.js, absent in the OCaml test runner). The picker's "load more"
;; sentinel binds its `revealed` trigger through it. Model it as a recording stub:
;; binding the sentinel registers its reveal callback; the test fires it explicitly
;; to simulate the sentinel scrolling into view. Without this, process-elements
;; would throw on the sentinel's trigger and the paged-in content would never bind.
(define _last-reveal nil)
(define observe-intersection
  (fn (el callback once delay) (set! _last-reveal callback)))
(define reset-reveal! (fn () (set! _last-reveal nil)))
(define fire-reveal! (fn () (when _last-reveal (_last-reveal))))

;; ── 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. The
;; engine's triggers listen directly on the element carrying the verb (the form),
;; so the event need not bubble.
(define fire-event!
  (fn (el type)
    (host-call el "dispatchEvent" (host-new "Event" type))))

;; Candidate-row / sentinel counts via the engine's own dom-query-all — asserts
;; through the platform DOM API, not a private shape. Sentinel rows carry .rp-more;
;; candidate rows are the rest (mirrors the spec's `li:not(.rp-more)`).
(define count-li (fn (c) (len (dom-query-all c "li"))))
(define count-more (fn (c) (len (dom-query-all c "li.rp-more"))))
(define count-candidates (fn (c) (- (count-li c) (count-more c))))

;; ── markup builders (the expanded ~relate-picker, server-rendered) ──
;; The picker form, exactly as ~relate-picker (lib/host/sx/relate-picker.sx)
;; expands: sx-get the candidate list, innerHTML-swap into its results <ul> on
;; "load" and on a debounced "input".
(define picker-form-html
  (fn (slug kind)
    (str
      "<form class=\"relate-picker\" data-slug=\"" slug "\" data-kind=\"" kind "\""
        " sx-get=\"/" slug "/relate-options\""
        " sx-trigger=\"input delay:200ms, load\""
        " sx-target=\"#rp-" kind "-results\""
        " sx-swap=\"innerHTML\""
        " sx-retry=\"exponential:1000:30000\">"
        "<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
        "<input type=\"text\" name=\"q\" class=\"rp-filter\" placeholder=\"filter…\">"
        "<ul id=\"rp-" kind "-results\" class=\"rp-results\"></ul>"
      "</form>")))

;; One candidate row, as host/blog--picker-item renders it: relating re-renders the
;; whole editor (sx-target=#rel-editor-KIND, sx-swap=outerHTML).
(define row-html
  (fn (slug kind cand title)
    (str
      "<li id=\"cand-" kind "-" cand "\">"
        "<form method=\"post\" action=\"/" slug "/relate\""
          " sx-post=\"/" slug "/relate\""
          " sx-target=\"#rel-editor-" kind "\""
          " sx-swap=\"outerHTML\">"
          "<input type=\"hidden\" name=\"other\" value=\"" cand "\">"
          "<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
          "<button type=\"submit\">" title "</button>"
        "</form>"
      "</li>")))

;; One CURRENT-relation row, as host/blog--relation-editor renders it: removing
;; re-renders the whole editor (sx-target=#rel-editor-KIND, sx-swap=outerHTML).
(define cur-row-html
  (fn (slug kind other label)
    (str
      "<li>"
        "<a href=\"/" other "/\">" label "</a> "
        "<form method=\"post\" action=\"/" slug "/unrelate\""
          " sx-post=\"/" slug "/unrelate\""
          " sx-target=\"#rel-editor-" kind "\""
          " sx-swap=\"outerHTML\">"
          "<input type=\"hidden\" name=\"other\" value=\"" other "\">"
          "<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
          "<button type=\"submit\">remove</button>"
        "</form>"
      "</li>")))

;; The kind's relation editor: #rel-editor-KIND wrapping the current-relations list
;; and the picker (with `candidates` already in its results <ul>). This is what the
;; relate/unrelate handlers return and what the initial edit page renders.
(define editor-html
  (fn (kind current candidates)
    (str
      "<div id=\"rel-editor-" kind "\">"
        "<h3>" kind "</h3>"
        "<ul class=\"rp-current\">" current "</ul>"
        "<form class=\"relate-picker\" data-slug=\"host\" data-kind=\"" kind "\""
          " sx-get=\"/host/relate-options\" sx-trigger=\"input delay:200ms, load\""
          " sx-target=\"#rp-" kind "-results\" sx-swap=\"innerHTML\">"
          "<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
          "<input type=\"text\" name=\"q\" class=\"rp-filter\">"
          "<ul id=\"rp-" kind "-results\" class=\"rp-results\">" candidates "</ul>"
        "</form>"
      "</div>")))

;; The "load more" sentinel, as host/blog--picker-more renders it.
(define sentinel-html
  (fn (slug kind offset)
    (str
      "<li class=\"rp-more\""
        " sx-get=\"/" slug "/relate-options?kind=" kind "&q=&offset=" offset "\""
        " sx-trigger=\"revealed\""
        " sx-swap=\"outerHTML\""
        " sx-retry=\"exponential:1000:30000\">Loading more…</li>")))

;; A page of N candidate rows "cand-i" / "Item i" for i in [lo, hi).
(define rows-html
  (fn (slug kind lo hi)
    (let ((acc ""))
      (let loop ((i lo))
        (if (< i hi)
          (do
            (set! acc (str acc (row-html slug kind (str "item-" i) (str "Picker Item " i))))
            (loop (+ i 1)))
          acc)))))

;; ── relating a candidate re-syncs the editor (adds to the current list) ─
;; Regression for "adding a related post doesn't add it to the list": the candidate
;; relate form re-renders the whole #rel-editor-KIND (outerHTML), so the related
;; post moves into the current-relations list and the fresh picker re-loads — both
;; lists stay in sync, in-page, no reload.
(defsuite
  "relate-picker:relate-resyncs-editor"
  (deftest
    "relating a candidate adds it to the current list and re-loads the picker"
    (reset-fetch-mock!)
    (reset-reveal!)
    ;; the picker's load shows one candidate (item-07) to click
    (set! _mock-fetch-body (row-html "host" "related" "item-07" "Picker Item 07"))
    (let
      ((root (mk-root (str "<div id=\"content\">"
                        (editor-html "related" "" "")
                        "</div>")))
        (results (dom-query "#rp-related-results")))
      (process-elements root)
      ;; load populated the candidate; current list empty
      (assert-equal 1 (count-candidates results))
      (assert-nil (dom-query "a[href=\"/item-07/\"]"))
      ;; clicking it: the relate POST returns the re-rendered editor (item-07 now in
      ;; the current list), and the fresh picker re-loads OTHER candidates.
      (set! _mock-editor-body
        (editor-html "related" (cur-row-html "host" "related" "item-07" "Picker Item 07") ""))
      (set! _mock-fetch-body (rows-html "host" "related" 8 11))   ;; refreshed pool
      (fire-event! (dom-query "#cand-related-item-07 form") "submit")
      ;; the related post is now in the current list (added, not just removed)...
      (assert-true (not (nil? (dom-query "a[href=\"/item-07/\"]"))))
      ;; ...and the picker is NOT cleared — it re-loaded a fresh candidate page
      (assert-equal 3 (count-candidates (dom-query "#rp-related-results")))
      (clear-root! root))))

;; ── Phase 1: load / filter / paging / error-retry ───────────────────
(defsuite
  "relate-picker:load"
  (deftest
    "the load trigger populates the results on first render"
    (reset-fetch-mock!)
    (reset-reveal!)
    ;; one full page of candidates (no sentinel) returned for the load fetch
    (set! _mock-fetch-body (rows-html "host" "related" 0 5))
    (let
      ((root (mk-root (picker-form-html "host" "related")))
        (results (dom-query "#rp-related-results")))
      ;; results empty before binding
      (assert-equal 0 (count-candidates results))
      ;; process-elements binds the "load" trigger; the harness fires its
      ;; set-timeout synchronously, so the populate fetch runs here
      (process-elements root)
      (assert-true (> _mock-fetch-calls 0))
      (assert-equal 5 (count-candidates results))
      ;; Phase 3: the SAME populated tree renders to the console — the results
      ;; <ul> becomes a bulleted list of candidate titles. (Console renderer driven
      ;; for free by the engine tree; web/console-render.sx.)
      (let ((txt (render-to-console results)))
        (assert-true (contains? txt "• Picker Item 0"))
        (assert-true (contains? txt "• Picker Item 4")))
      (clear-root! root))))

(defsuite
  "relate-picker:filter"
  (deftest
    "typing in the filter re-fetches and narrows the candidates"
    (reset-fetch-mock!)
    (reset-reveal!)
    ;; load shows 5 candidates...
    (set! _mock-fetch-body (rows-html "host" "related" 0 5))
    (let
      ((root (mk-root (picker-form-html "host" "related")))
        (results (dom-query "#rp-related-results"))
        (form (dom-query ".relate-picker"))
        (filter (dom-query ".rp-filter")))
      (process-elements root)
      (assert-equal 5 (count-candidates results))
      ;; ...the filter narrows to a single match
      (set! _mock-fetch-body (row-html "host" "related" "item-13" "Picker Item 13"))
      (dom-set-attr filter "value" "Item 13")
      ;; debounced "input" trigger (delay fires synchronously in the harness)
      (fire-event! form "input")
      (assert-equal 1 (count-candidates results))
      (clear-root! root))))

(defsuite
  "relate-picker:paging"
  (deftest
    "revealing the load-more sentinel pages in the next page and replaces it"
    (reset-fetch-mock!)
    (reset-reveal!)
    ;; page 1: a full page of rows FOLLOWED BY the load-more sentinel
    (set! _mock-fetch-body (str (rows-html "host" "related" 0 20)
                             (sentinel-html "host" "related" 20)))
    (let
      ((root (mk-root (picker-form-html "host" "related")))
        (results (dom-query "#rp-related-results")))
      (process-elements root)
      ;; first page populated, sentinel present
      (assert-equal 20 (count-candidates results))
      (assert-equal 1 (count-more results))
      ;; page 2: the last page — more rows, NO sentinel
      (set! _mock-fetch-body (rows-html "host" "related" 20 25))
      ;; the sentinel scrolling into view fires its `revealed` trigger
      (fire-reveal!)
      ;; the new rows are appended and the sentinel (swapped outerHTML) is gone
      (assert-equal 25 (count-candidates results))
      (assert-equal 0 (count-more results))
      (clear-root! root))))

(defsuite
  "relate-picker:error-retry"
  (deftest
    "a dropped fetch shows .sx-error, and the next success clears it"
    (reset-fetch-mock!)
    (reset-reveal!)
    ;; the candidate fetch drops on load
    (set! _mock-fetch-fail true)
    (let
      ((root (mk-root (picker-form-html "host" "related")))
        (results (dom-query "#rp-related-results"))
        (form (dom-query ".relate-picker")))
      ;; sx-retry self-heals via exponential backoff on set-timeout — which fires
      ;; SYNCHRONOUSLY in the harness, so a retry against a still-failing mock would
      ;; recurse forever. Strip it: we assert the VISIBLE error state and that the
      ;; next *request* (the user retyping) clears it. The backoff math itself is
      ;; covered by test-engine.sx (parse-retry-spec / next-retry-ms).
      (dom-remove-attr form "sx-retry")
      (process-elements root)
      ;; visible failure state: .sx-error lands on the picker form
      (assert-true (dom-has-class? form "sx-error"))
      (assert-equal 0 (count-candidates results))
      ;; Phase 3: the console rendering of the errored picker shows the failure as
      ;; a flagged line (the terminal's "red line") — same tree, different binding.
      (assert-true (contains? (render-to-console form) "✖"))
      ;; recovery: the endpoint works again, the next input retries and the error
      ;; clears as the results populate
      (set! _mock-fetch-fail false)
      (set! _mock-fetch-body (rows-html "host" "related" 0 3))
      (fire-event! form "input")
      (assert-false (dom-has-class? form "sx-error"))
      (assert-equal 3 (count-candidates results))
      (clear-root! root))))

;; ── regression: removing a relation must not clear the relate picker ─
;; The remove button re-renders the kind's editor (outerHTML #rel-editor-KIND): the
;; row leaves the current list and the FRESH picker re-loads its candidates. (Bug:
;; the old plain-boosted remove redirected and the re-rendered picker came back
;; empty — here the picker repopulates instead of clearing to 0.)
(defsuite
  "relate-picker:unrelate-keeps-picker"
  (deftest
    "removing a current relation re-syncs the editor and re-loads the picker"
    (reset-fetch-mock!)
    (reset-reveal!)
    ;; start: Beta + Gamma are related; the picker (after load) shows nothing yet
    (set! _mock-fetch-body "")
    (let
      ((root (mk-root (str "<div id=\"content\">"
               (editor-html "related"
                 (str (cur-row-html "host" "related" "beta" "Beta")
                      (cur-row-html "host" "related" "gamma" "Gamma"))
                 "")
               "</div>"))))
      (process-elements root)
      (assert-equal 2 (len (dom-query-all (dom-query "#rel-editor-related") "ul.rp-current li")))
      ;; remove Beta: the unrelate POST returns the editor with only Gamma current,
      ;; and the fresh picker re-loads candidates (Beta is available again).
      (set! _mock-editor-body
        (editor-html "related" (cur-row-html "host" "related" "gamma" "Gamma") ""))
      (set! _mock-fetch-body (rows-html "host" "related" 0 4))
      (fire-event! (dom-query "form") "submit")   ;; Beta's remove form (first form)
      ;; Beta is gone from the current list; Gamma stays
      (assert-nil (dom-query "a[href=\"/beta/\"]"))
      (assert-true (not (nil? (dom-query "a[href=\"/gamma/\"]"))))
      (assert-equal 1 (len (dom-query-all (dom-query "#rel-editor-related") "ul.rp-current li")))
      ;; and the picker is NOT cleared — it re-loaded a fresh candidate page
      (assert-equal 4 (count-candidates (dom-query "#rp-related-results")))
      (clear-root! root))))

;; ── Phase 3: the engine drives a non-browser target (the console) ───
;; render-to-console (web/console-render.sx) prints the live engine tree as text.
;; These assert the picker's terminal rendering directly on a built tree — the
;; console platform's draw step, proven without a terminal.
(defsuite
  "relate-picker:console"
  (deftest
    "the picker form renders as a filter field over a bulleted candidate list"
    (let
      ((root (mk-root (str
               "<form class=\"relate-picker\">"
                 "<input type=\"hidden\" name=\"kind\" value=\"related\">"
                 "<input type=\"text\" name=\"q\" class=\"rp-filter\" placeholder=\"filter…\">"
                 "<ul class=\"rp-results\">"
                   (row-html "host" "related" "item-0" "Picker Item 0")
                   (row-html "host" "related" "item-1" "Picker Item 1")
                   (sentinel-html "host" "related" 20)
                 "</ul>"
               "</form>")))
        (form (dom-query ".relate-picker")))
      (let ((txt (render-to-console form)))
        ;; the text input becomes a labelled field (placeholder as the label)...
        (assert-true (contains? txt "filter…: ["))
        ;; ...the hidden kind input is not drawn...
        (assert-false (contains? txt "related: ["))
        ;; ...each candidate is a bullet, the sentinel an ellipsis line
        (assert-true (contains? txt "• Picker Item 0"))
        (assert-true (contains? txt "• Picker Item 1"))
        (assert-true (contains? txt "… Loading more…")))
      (clear-root! root)))
  (deftest
    "an empty results list renders no bullets"
    (let
      ((root (mk-root "<ul class=\"rp-results\"></ul>"))
        (results (dom-query root ".rp-results")))   ;; scope to this root
      (assert-equal "" (render-to-console results))
      (clear-root! root))))