giles
53c0ec14da
The synchronous harness binds mocks as plain NativeFns, so no harness test
could exercise the real CEK perform/suspend/resume path — the HO+perform
element-drop class (S10) was structurally invisible (hosts.md C21).
Add harness-run-perform to spec/harness.sx: drives make-cek-state/
cek-step-loop, services each (perform {:op X :args L}) suspension from the
session's platform mocks (entry logged before invocation, C22-consistent),
cek-resumes with the mock value, loops to terminal; clear error on an
unmocked op. Shared arity dispatch extracted as harness-invoke-mock.
Pins (gate-C21-perform-mode-harness): single suspension, arithmetic-frame
resume, sequential performs, unmocked-op error, and the S10 probe — map
over a perform-suspending lambda keeps ALL 3 elements through 3
suspensions on the CEK path (localizing the drop class to serving-JIT).
290/0 under OCaml run_tests; harness self-suite green.
Caveat (documented): requires the runner's cek-* driver bindings — absent
on bare sx_server/MCP, the same runner-only-binding theme as section B.
Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
266 lines
7.9 KiB
Plaintext
266 lines
7.9 KiB
Plaintext
;; Assert condition is truthy, error with message
|
|
|
|
(define-library
|
|
(sx harness)
|
|
(export
|
|
assert
|
|
assert=
|
|
default-platform
|
|
make-harness
|
|
harness-reset!
|
|
harness-log
|
|
harness-get
|
|
harness-set!
|
|
make-interceptor
|
|
install-interceptors
|
|
harness-run-perform
|
|
io-calls
|
|
io-call-count
|
|
io-call-nth
|
|
io-call-args
|
|
io-call-result
|
|
assert-io-called
|
|
assert-no-io
|
|
assert-io-count
|
|
assert-io-args
|
|
assert-io-result
|
|
assert-state)
|
|
(begin
|
|
(define
|
|
assert
|
|
(fn
|
|
(condition msg)
|
|
(when (not condition) (error (or msg "Assertion failed")))))
|
|
(define
|
|
assert=
|
|
(fn
|
|
(actual expected msg)
|
|
(when
|
|
(not (= actual expected))
|
|
(error (or msg (str "Expected " expected ", got " actual))))))
|
|
(define default-platform {:get-cookie (fn (name) nil) :local-storage-get (fn (key) nil) :emit-dom (fn (op &rest args) nil) :request-arg (fn (name) nil) :append-child (fn (parent child) nil) :remove-class (fn (el cls) nil) :action (fn (service name &rest args) {:ok true}) :abort (fn (code) nil) :now (fn () 0) :get-element (fn (id) nil) :add-class (fn (el cls) nil) :query (fn (service name &rest args) (list)) :fetch (fn (url &rest opts) {:ok true :body "" :status 200}) :remove-child (fn (parent child) nil) :set-text (fn (el text) nil) :set-attr (fn (el name val) nil) :config (fn (key) nil) :request-path (fn () "/") :create-element (fn (tag) nil) :url-for (fn (endpoint &rest args) "/mock-url") :set-cookie (fn (name val &rest opts) nil) :local-storage-set (fn (key val) nil) :sleep (fn (ms) nil) :frag (fn (service comp &rest args) "") :app-url (fn (service &rest path) "/mock-app-url") :csrf-token (fn () "test-csrf-token") :current-user (fn () nil)})
|
|
(define
|
|
make-harness
|
|
:effects ()
|
|
(fn
|
|
(&key platform)
|
|
(let
|
|
((merged (if (nil? platform) default-platform (merge default-platform platform))))
|
|
{:state {:dom nil :storage {} :cookies {}} :platform merged :log (list)})))
|
|
(define
|
|
harness-reset!
|
|
:effects ()
|
|
(fn
|
|
(session)
|
|
(dict-set! session "log" (list))
|
|
(dict-set! session "state" {:dom nil :storage {} :cookies {}})
|
|
session))
|
|
(define
|
|
harness-log
|
|
:effects ()
|
|
(fn
|
|
(session &key op)
|
|
(let
|
|
((log (get session "log")))
|
|
(if
|
|
(nil? op)
|
|
log
|
|
(filter (fn (entry) (= (get entry "op") op)) log)))))
|
|
(define
|
|
harness-get
|
|
:effects ()
|
|
(fn (session key) (get (get session "state") key)))
|
|
(define
|
|
harness-set!
|
|
:effects ()
|
|
(fn
|
|
(session key value)
|
|
(dict-set! (get session "state") key value)
|
|
nil))
|
|
(define
|
|
harness-invoke-mock
|
|
:effects ()
|
|
(fn
|
|
(mock-fn args)
|
|
(if
|
|
(empty? args)
|
|
(mock-fn)
|
|
(if
|
|
(= 1 (len args))
|
|
(mock-fn (first args))
|
|
(if
|
|
(= 2 (len args))
|
|
(mock-fn (first args) (nth args 1))
|
|
(if
|
|
(= 3 (len args))
|
|
(mock-fn
|
|
(first args)
|
|
(nth args 1)
|
|
(nth args 2))
|
|
(apply mock-fn args)))))))
|
|
(define
|
|
make-interceptor
|
|
:effects ()
|
|
(fn
|
|
(session op-name mock-fn)
|
|
(fn
|
|
(&rest args)
|
|
(let
|
|
((entry {:op op-name :result nil :args args}) (log (get session "log")))
|
|
(append! log entry)
|
|
(let
|
|
((result (harness-invoke-mock mock-fn args)))
|
|
(dict-set! entry "result" result)
|
|
result)))))
|
|
(define
|
|
install-interceptors
|
|
:effects ()
|
|
(fn
|
|
(session env)
|
|
(for-each
|
|
(fn
|
|
(key)
|
|
(let
|
|
((mock-fn (get (get session "platform") key))
|
|
(interceptor (make-interceptor session key mock-fn)))
|
|
(env-bind! env key interceptor)))
|
|
(keys (get session "platform")))
|
|
env))
|
|
(define
|
|
harness-run-perform
|
|
:effects ()
|
|
(fn
|
|
(session expr env)
|
|
(let
|
|
((drive (fn (self state) (if (cek-suspended? state) (let ((req (cek-io-request state))) (let ((op (get req "op")) (args (or (get req "args") (list)))) (let ((mock-fn (get (get session "platform") op))) (when (nil? mock-fn) (error (str "harness-run-perform: no mock for op " op))) (let ((entry {:op op :result nil :args args}) (log (get session "log"))) (append! log entry) (let ((result (harness-invoke-mock mock-fn args))) (dict-set! entry "result" result) (self self (cek-resume state result))))))) (cek-value state)))))
|
|
(drive drive (cek-step-loop (make-cek-state expr env (list)))))))
|
|
(define
|
|
io-calls
|
|
:effects ()
|
|
(fn
|
|
(session op-name)
|
|
(filter
|
|
(fn (entry) (= (get entry "op") op-name))
|
|
(get session "log"))))
|
|
(define
|
|
io-call-count
|
|
:effects ()
|
|
(fn (session op-name) (len (io-calls session op-name))))
|
|
(define
|
|
io-call-nth
|
|
:effects ()
|
|
(fn
|
|
(session op-name n)
|
|
(let
|
|
((calls (io-calls session op-name)))
|
|
(if (< n (len calls)) (nth calls n) nil))))
|
|
(define
|
|
io-call-args
|
|
:effects ()
|
|
(fn
|
|
(session op-name n)
|
|
(let
|
|
((call (io-call-nth session op-name n)))
|
|
(if (nil? call) nil (get call "args")))))
|
|
(define
|
|
io-call-result
|
|
:effects ()
|
|
(fn
|
|
(session op-name n)
|
|
(let
|
|
((call (io-call-nth session op-name n)))
|
|
(if (nil? call) nil (get call "result")))))
|
|
(define
|
|
assert-io-called
|
|
:effects ()
|
|
(fn
|
|
(session op-name)
|
|
(assert
|
|
(> (io-call-count session op-name) 0)
|
|
(str "Expected IO operation " op-name " to be called but it was not"))))
|
|
(define
|
|
assert-no-io
|
|
:effects ()
|
|
(fn
|
|
(session op-name)
|
|
(assert
|
|
(= (io-call-count session op-name) 0)
|
|
(str
|
|
"Expected IO operation "
|
|
op-name
|
|
" not to be called but it was called "
|
|
(io-call-count session op-name)
|
|
" time(s)"))))
|
|
(define
|
|
assert-io-count
|
|
:effects ()
|
|
(fn
|
|
(session op-name expected)
|
|
(let
|
|
((actual (io-call-count session op-name)))
|
|
(assert
|
|
(= actual expected)
|
|
(str
|
|
"Expected "
|
|
op-name
|
|
" to be called "
|
|
expected
|
|
" time(s) but was called "
|
|
actual
|
|
" time(s)")))))
|
|
(define
|
|
assert-io-args
|
|
:effects ()
|
|
(fn
|
|
(session op-name n expected-args)
|
|
(let
|
|
((actual (io-call-args session op-name n)))
|
|
(assert
|
|
(equal? actual expected-args)
|
|
(str
|
|
"Expected call "
|
|
n
|
|
" to "
|
|
op-name
|
|
" with args "
|
|
(str expected-args)
|
|
" but got "
|
|
(str actual))))))
|
|
(define
|
|
assert-io-result
|
|
:effects ()
|
|
(fn
|
|
(session op-name n expected)
|
|
(let
|
|
((actual (io-call-result session op-name n)))
|
|
(assert
|
|
(equal? actual expected)
|
|
(str
|
|
"Expected call "
|
|
n
|
|
" to "
|
|
op-name
|
|
" to return "
|
|
(str expected)
|
|
" but got "
|
|
(str actual))))))
|
|
(define
|
|
assert-state
|
|
:effects ()
|
|
(fn
|
|
(session key expected)
|
|
(let
|
|
((actual (harness-get session key)))
|
|
(assert
|
|
(equal? actual expected)
|
|
(str
|
|
"Expected state "
|
|
key
|
|
" to be "
|
|
(str expected)
|
|
" but got "
|
|
(str actual)))))))) ;; end define-library
|
|
|
|
;; Re-export to global namespace for backward compatibility
|
|
(import (sx harness))
|