diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index b09a482a..8a4e1d44 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -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 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 -> diff --git a/web/tests/test-relate-picker.sx b/web/tests/test-relate-picker.sx new file mode 100644 index 00000000..e275353c --- /dev/null +++ b/web/tests/test-relate-picker.sx @@ -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
  • wrapping a relate
    . +(define picker-row-html + (fn (slug kind title) + (str + "
    "))) + +;; ── 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
  • — 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))))