WIP: pre-existing changes from WASM browser work + test infrastructure
Accumulated changes from WASM browser development sessions: - sx_runtime.ml: signal subscription + notify, env unwrap tolerance - sx_browser.bc.js: rebuilt js_of_ocaml browser kernel - sx_browser.bc.wasm.js + assets: WASM browser kernel build - sx-platform.js browser tests (test_js, test_platform, test_wasm) - Playwright sx-inspect.js: interactive page inspector tool - harness-web.sx: DOM assertion updates - deploy.sh, Dockerfile, dune-project: build config updates - test-stepper.sx: stepper unit tests - reader-macro-demo plan update Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -1,154 +1,320 @@
|
||||
;; ==========================================================================
|
||||
;; web/harness-web.sx — Web platform testing extensions
|
||||
;;
|
||||
;; Extends spec/harness.sx with DOM mocking, event simulation, and
|
||||
;; web-specific assertions. Depends on web/signals.sx for reactive features.
|
||||
;;
|
||||
;; Mock DOM: lightweight element stubs that record operations.
|
||||
;; No real browser needed — runs on any host.
|
||||
;; ==========================================================================
|
||||
(define
|
||||
mock-element
|
||||
:effects ()
|
||||
(fn ((tag :as string) &key class id) {:children (list) :listeners {} :event-log (list) :tag tag :text "" :attrs (merge {} (if class {:class class} {}) (if id {:id id} {}))}))
|
||||
|
||||
(define
|
||||
mock-set-text!
|
||||
:effects (mutation)
|
||||
(fn (el (text :as string)) (dict-set! el "text" text)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Mock DOM elements
|
||||
;; --------------------------------------------------------------------------
|
||||
(define
|
||||
mock-append-child!
|
||||
:effects (mutation)
|
||||
(fn (parent child) (append! (get parent "children") child)))
|
||||
|
||||
;; Create a mock element with tag name, attrs dict, children list, and event log
|
||||
(define mock-element :effects []
|
||||
(fn ((tag :as string) &key class id)
|
||||
{:tag tag
|
||||
:attrs (merge {} (if class {:class class} {}) (if id {:id id} {}))
|
||||
:children (list)
|
||||
:text ""
|
||||
:event-log (list)
|
||||
:listeners {}}))
|
||||
(define
|
||||
mock-set-attr!
|
||||
:effects (mutation)
|
||||
(fn (el (name :as string) value) (dict-set! (get el "attrs") name value)))
|
||||
|
||||
;; Set text content on mock element
|
||||
(define mock-set-text! :effects [mutation]
|
||||
(fn (el (text :as string))
|
||||
(dict-set! el "text" text)))
|
||||
(define
|
||||
mock-get-attr
|
||||
:effects ()
|
||||
(fn (el (name :as string)) (get (get el "attrs") name)))
|
||||
|
||||
;; Append child to mock element
|
||||
(define mock-append-child! :effects [mutation]
|
||||
(fn (parent child)
|
||||
(append! (get parent "children") child)))
|
||||
|
||||
;; Set attribute on mock element
|
||||
(define mock-set-attr! :effects [mutation]
|
||||
(fn (el (name :as string) value)
|
||||
(dict-set! (get el "attrs") name value)))
|
||||
|
||||
;; Get attribute from mock element
|
||||
(define mock-get-attr :effects []
|
||||
(fn (el (name :as string))
|
||||
(get (get el "attrs") name)))
|
||||
|
||||
;; Add event listener to mock element
|
||||
(define mock-add-listener! :effects [mutation]
|
||||
(fn (el (event-name :as string) (handler :as lambda))
|
||||
(let ((listeners (get el "listeners")))
|
||||
(when (not (has-key? listeners event-name))
|
||||
(define
|
||||
mock-add-listener!
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(el (event-name :as string) (handler :as lambda))
|
||||
(let
|
||||
((listeners (get el "listeners")))
|
||||
(when
|
||||
(not (has-key? listeners event-name))
|
||||
(dict-set! listeners event-name (list)))
|
||||
(append! (get listeners event-name) handler))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Event simulation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Simulate a click event on a mock element
|
||||
(define simulate-click :effects [mutation]
|
||||
(fn (el)
|
||||
(let ((handlers (get (get el "listeners") "click")))
|
||||
(when handlers
|
||||
(for-each (fn (h) (cek-call h (list {:type "click" :target el})))
|
||||
handlers))
|
||||
(define
|
||||
simulate-click
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(el)
|
||||
(let
|
||||
((handlers (get (get el "listeners") "click")))
|
||||
(when
|
||||
handlers
|
||||
(for-each (fn (h) (cek-call h (list {:target el :type "click"}))) handlers))
|
||||
(append! (get el "event-log") {:type "click"}))))
|
||||
|
||||
;; Simulate an input event with a value
|
||||
(define simulate-input :effects [mutation]
|
||||
(fn (el (value :as string))
|
||||
(define
|
||||
simulate-input
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(el (value :as string))
|
||||
(mock-set-attr! el "value" value)
|
||||
(let ((handlers (get (get el "listeners") "input")))
|
||||
(when handlers
|
||||
(for-each (fn (h) (cek-call h (list {:type "input" :target el})))
|
||||
handlers))
|
||||
(append! (get el "event-log") {:type "input" :value value}))))
|
||||
(let
|
||||
((handlers (get (get el "listeners") "input")))
|
||||
(when
|
||||
handlers
|
||||
(for-each (fn (h) (cek-call h (list {:target el :type "input"}))) handlers))
|
||||
(append! (get el "event-log") {:value value :type "input"}))))
|
||||
|
||||
;; Simulate a custom event (for lake→island bridge)
|
||||
(define simulate-event :effects [mutation]
|
||||
(fn (el (event-name :as string) detail)
|
||||
(let ((handlers (get (get el "listeners") event-name)))
|
||||
(when handlers
|
||||
(for-each (fn (h) (cek-call h (list {:type event-name :detail detail :target el})))
|
||||
handlers))
|
||||
(append! (get el "event-log") {:type event-name :detail detail}))))
|
||||
(define
|
||||
simulate-event
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(el (event-name :as string) detail)
|
||||
(let
|
||||
((handlers (get (get el "listeners") event-name)))
|
||||
(when
|
||||
handlers
|
||||
(for-each (fn (h) (cek-call h (list {:target el :detail detail :type event-name}))) handlers))
|
||||
(append! (get el "event-log") {:detail detail :type event-name}))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; DOM assertions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Assert mock element has specific text content
|
||||
(define assert-text :effects []
|
||||
(fn (el (expected :as string))
|
||||
(let ((actual (get el "text")))
|
||||
(assert= actual expected
|
||||
(define
|
||||
assert-text
|
||||
:effects ()
|
||||
(fn
|
||||
(el (expected :as string))
|
||||
(let
|
||||
((actual (get el "text")))
|
||||
(assert=
|
||||
actual
|
||||
expected
|
||||
(str "Expected text \"" expected "\", got \"" actual "\"")))))
|
||||
|
||||
;; Assert mock element has an attribute with expected value
|
||||
(define assert-attr :effects []
|
||||
(fn (el (name :as string) expected)
|
||||
(let ((actual (mock-get-attr el name)))
|
||||
(assert= actual expected
|
||||
(define
|
||||
assert-attr
|
||||
:effects ()
|
||||
(fn
|
||||
(el (name :as string) expected)
|
||||
(let
|
||||
((actual (mock-get-attr el name)))
|
||||
(assert=
|
||||
actual
|
||||
expected
|
||||
(str "Expected attr " name "=\"" expected "\", got \"" actual "\"")))))
|
||||
|
||||
;; Assert mock element has a CSS class
|
||||
(define assert-class :effects []
|
||||
(fn (el (class-name :as string))
|
||||
(let ((classes (or (mock-get-attr el "class") "")))
|
||||
(assert (contains? (split classes " ") class-name)
|
||||
(define
|
||||
assert-class
|
||||
:effects ()
|
||||
(fn
|
||||
(el (class-name :as string))
|
||||
(let
|
||||
((classes (or (mock-get-attr el "class") "")))
|
||||
(assert
|
||||
(contains? (split classes " ") class-name)
|
||||
(str "Expected class \"" class-name "\" in \"" classes "\"")))))
|
||||
|
||||
;; Assert mock element does NOT have a CSS class
|
||||
(define assert-no-class :effects []
|
||||
(fn (el (class-name :as string))
|
||||
(let ((classes (or (mock-get-attr el "class") "")))
|
||||
(assert (not (contains? (split classes " ") class-name))
|
||||
(define
|
||||
assert-no-class
|
||||
:effects ()
|
||||
(fn
|
||||
(el (class-name :as string))
|
||||
(let
|
||||
((classes (or (mock-get-attr el "class") "")))
|
||||
(assert
|
||||
(not (contains? (split classes " ") class-name))
|
||||
(str "Expected no class \"" class-name "\" but found in \"" classes "\"")))))
|
||||
|
||||
;; Assert mock element has N children
|
||||
(define assert-child-count :effects []
|
||||
(fn (el (n :as number))
|
||||
(let ((actual (len (get el "children"))))
|
||||
(assert= actual n
|
||||
(str "Expected " n " children, got " actual)))))
|
||||
(define
|
||||
assert-child-count
|
||||
:effects ()
|
||||
(fn
|
||||
(el (n :as number))
|
||||
(let
|
||||
((actual (len (get el "children"))))
|
||||
(assert= actual n (str "Expected " n " children, got " actual)))))
|
||||
|
||||
;; Assert an event was fired on mock element
|
||||
(define assert-event-fired :effects []
|
||||
(fn (el (event-name :as string))
|
||||
(assert (some (fn (e) (= (get e "type") event-name)) (get el "event-log"))
|
||||
(define
|
||||
assert-event-fired
|
||||
:effects ()
|
||||
(fn
|
||||
(el (event-name :as string))
|
||||
(assert
|
||||
(some (fn (e) (= (get e "type") event-name)) (get el "event-log"))
|
||||
(str "Expected event \"" event-name "\" to have been fired"))))
|
||||
|
||||
;; Assert an event was NOT fired on mock element
|
||||
(define assert-no-event :effects []
|
||||
(fn (el (event-name :as string))
|
||||
(assert (not (some (fn (e) (= (get e "type") event-name)) (get el "event-log")))
|
||||
(define
|
||||
assert-no-event
|
||||
:effects ()
|
||||
(fn
|
||||
(el (event-name :as string))
|
||||
(assert
|
||||
(not
|
||||
(some (fn (e) (= (get e "type") event-name)) (get el "event-log")))
|
||||
(str "Expected event \"" event-name "\" to NOT have been fired"))))
|
||||
|
||||
;; Count how many times an event was fired
|
||||
(define event-fire-count :effects []
|
||||
(fn (el (event-name :as string))
|
||||
(len (filter (fn (e) (= (get e "type") event-name)) (get el "event-log")))))
|
||||
(define
|
||||
event-fire-count
|
||||
:effects ()
|
||||
(fn
|
||||
(el (event-name :as string))
|
||||
(len
|
||||
(filter (fn (e) (= (get e "type") event-name)) (get el "event-log")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Web harness constructor — extends make-harness with DOM mock state
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-web-harness :effects []
|
||||
(fn (&key platform)
|
||||
(let ((h (make-harness :platform platform)))
|
||||
(harness-set! h "dom" {:root (mock-element "div" :id "root")
|
||||
:elements {}})
|
||||
(define
|
||||
make-web-harness
|
||||
:effects ()
|
||||
(fn
|
||||
(&key platform)
|
||||
(let
|
||||
((h (make-harness :platform platform)))
|
||||
(harness-set! h "dom" {:elements {} :root (mock-element "div" :id "root")})
|
||||
h)))
|
||||
|
||||
(define
|
||||
is-renderable?
|
||||
:effects ()
|
||||
(fn
|
||||
(value)
|
||||
(cond
|
||||
(nil? value)
|
||||
true
|
||||
(string? value)
|
||||
true
|
||||
(number? value)
|
||||
true
|
||||
(boolean? value)
|
||||
true
|
||||
(dict? value)
|
||||
false
|
||||
(not (list? value))
|
||||
false
|
||||
(empty? value)
|
||||
true
|
||||
:else (let
|
||||
((head (first value)))
|
||||
(and (= (type-of head) "symbol") (not (dict? head)))))))
|
||||
|
||||
(define
|
||||
is-render-leak?
|
||||
:effects ()
|
||||
(fn (value) (and (not (nil? value)) (not (is-renderable? value)))))
|
||||
|
||||
(define
|
||||
assert-renderable
|
||||
:effects ()
|
||||
(fn
|
||||
(value label)
|
||||
(assert
|
||||
(is-renderable? value)
|
||||
(str
|
||||
"Render leak in "
|
||||
label
|
||||
": "
|
||||
(type-of value)
|
||||
(cond
|
||||
(dict? value)
|
||||
" — dict would appear as {:key val} text in output"
|
||||
(and (list? value) (not (empty? value)) (dict? (first value)))
|
||||
" — list of dicts would appear as raw data in output"
|
||||
:else " — non-renderable value would appear as text")))))
|
||||
|
||||
(define
|
||||
render-body-audit
|
||||
:effects ()
|
||||
(fn
|
||||
(values)
|
||||
(let
|
||||
((leaks (list)))
|
||||
(for-each
|
||||
(fn (v) (when (is-render-leak? v) (append! leaks {:leak-kind (cond (dict? v) "dict" (and (list? v) (not (empty? v)) (dict? (first v))) "list-of-dicts" :else "other") :value-type (type-of v)})))
|
||||
values)
|
||||
leaks)))
|
||||
|
||||
(define
|
||||
assert-render-body-clean
|
||||
:effects ()
|
||||
(fn
|
||||
(values label)
|
||||
(let
|
||||
((leaks (render-body-audit values)))
|
||||
(assert
|
||||
(empty? leaks)
|
||||
(str
|
||||
"Render body has "
|
||||
(len leaks)
|
||||
" leak(s) in "
|
||||
label
|
||||
". "
|
||||
"render-to-html/render-to-dom render ALL body expressions — "
|
||||
"put side effects in let bindings, not body expressions.")))))
|
||||
|
||||
(define
|
||||
mock-render
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(expr)
|
||||
(cond
|
||||
(nil? expr)
|
||||
nil
|
||||
(string? expr)
|
||||
(let ((el (mock-element "TEXT"))) (mock-set-text! el expr) el)
|
||||
(number? expr)
|
||||
(let ((el (mock-element "TEXT"))) (mock-set-text! el (str expr)) el)
|
||||
(not (list? expr))
|
||||
nil
|
||||
(empty? expr)
|
||||
nil
|
||||
:else (let
|
||||
((head (first expr)))
|
||||
(if
|
||||
(not (= (type-of head) "symbol"))
|
||||
nil
|
||||
(let
|
||||
((el (mock-element (symbol-name head))))
|
||||
(let
|
||||
loop
|
||||
((args (rest expr)))
|
||||
(when
|
||||
(not (empty? args))
|
||||
(let
|
||||
((arg (first args)))
|
||||
(if
|
||||
(= (type-of arg) "keyword")
|
||||
(when
|
||||
(not (empty? (rest args)))
|
||||
(mock-set-attr! el (keyword-name arg) (nth args 1))
|
||||
(loop (rest (rest args))))
|
||||
(do
|
||||
(let
|
||||
((child-el (mock-render arg)))
|
||||
(when child-el (mock-append-child! el child-el)))
|
||||
(loop (rest args)))))))
|
||||
el))))))
|
||||
|
||||
(define
|
||||
mock-render-fragment
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(exprs)
|
||||
(filter (fn (el) (not (nil? el))) (map mock-render exprs))))
|
||||
|
||||
(define
|
||||
assert-single-render-root
|
||||
:effects ()
|
||||
(fn
|
||||
(exprs label)
|
||||
(let
|
||||
((rendered (mock-render-fragment exprs)))
|
||||
(assert
|
||||
(= (len rendered) 1)
|
||||
(str
|
||||
"Expected single render root in "
|
||||
label
|
||||
" but got "
|
||||
(len rendered)
|
||||
" element(s). "
|
||||
"Multi-body let/begin in render-to-html/render-to-dom renders "
|
||||
"ALL expressions — put side effects in let bindings.")))))
|
||||
|
||||
(define
|
||||
assert-tag
|
||||
:effects ()
|
||||
(fn
|
||||
(el expected-tag)
|
||||
(assert
|
||||
(= (get el "tag") expected-tag)
|
||||
(str "Expected <" expected-tag "> but got <" (get el "tag") ">"))))
|
||||
|
||||
Reference in New Issue
Block a user