coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sx: step 11 — migrate prolog hook + add worker plugin

Browse Source 
Move `hs-prolog-hook` / `hs-set-prolog-hook!` / `prolog` out of
`lib/hyperscript/runtime.sx` into a self-contained plugin file at
`lib/hyperscript/plugins/prolog.sx`. The API surface is preserved —
`lib/prolog/hs-bridge.sx::pl-install-hs-hook!` still calls
`hs-set-prolog-hook!` exactly as before, just resolved to the plugin
file's binding rather than runtime.sx's.

Move the E39 worker stub registration out of `lib/hyperscript/parser.sx`
into `lib/hyperscript/plugins/worker.sx`. The plugin calls
`(hs-register-feature! "worker" ...)` at file load time. Behaviour is
identical — `worker MyWorker ...` raises the same helpful "plugin not
installed" error, just routed through the registry from a separate
file. The pre-existing `behavioral` test for the helpful error
("raises a helpful error when the worker plugin is not installed")
still passes via the new path.

Wire-up:
- OCaml `bin/run_tests.ml`: load `plugins/worker.sx` and
  `plugins/prolog.sx` after `runtime.sx`, before `integration.sx`.
- JS `tests/hs-kernel-eval.js`: extend HS module list with
  `hs-worker` / `hs-prolog`; add `HS_PLUGINS` resolver branch so the
  `hs-` prefix maps to `lib/hyperscript/plugins/`.
- WASM `hosts/ocaml/browser/bundle.sh`: copy plugin files into
  `dist/sx/hs-<name>.sx`.
- WASM `hosts/ocaml/browser/compile-modules.js`: add `hs-worker` /
  `hs-prolog` to `FILES`, `HS_DEPS`, and `HS_LAZY` so the lazy loader
  resolves them on first reference.
- Worker plugin carries a sentinel `(define hs-worker-loaded? true)`
  so `extractDefines` indexes it in the module manifest (the lazy
  loader skips files with no defines).

Mirrors `shared/static/wasm/sx/hs-{parser,runtime}.sx` are byte-identical
to source; new mirrors `hs-{prolog,worker}.sx` written via sx_write_file.

OCaml: 4545 passed, 1339 failed — matches baseline.
JS: 2591 passed, 2465 failed — matches baseline.
Smoke tests: `(prolog ...)` raises "prolog hook not installed" cleanly,
`(hs-set-prolog-hook! ...)` then `(prolog ...)` returns the hook result,
`(hs-compile "worker MyWorker def noop() end end")` raises the worker
stub error via the registry path.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-07 01:20:32 +00:00
parent c08e217e2a
commit 6328b810bd
21 changed files with 492 additions and 106 deletions
Download Patch File Download Diff File Expand all files Collapse all files

285
shared/static/wasm/sx/hs-runtime.sx
View File

@@ -12,29 +12,6 @@
;; Register an event listener. Returns unlisten function.
;; (hs-on target event-name handler) → unlisten-fn
(begin
(define _hs-config-log-all false)
(define _hs-log-captured (list))
(define
hs-set-log-all!
(fn (flag) (set! _hs-config-log-all (if flag true false))))
(define hs-get-log-captured (fn () _hs-log-captured))
(define
hs-clear-log-captured!
(fn () (begin (set! _hs-log-captured (list)) nil)))
(define
hs-log-event!
(fn
(msg)
(when
_hs-config-log-all
(begin
(set! _hs-log-captured (append _hs-log-captured (list msg)))
(host-call (host-global "console") "log" msg)
nil)))))
;; Register for every occurrence (no queuing — each fires independently).
;; Stock hyperscript queues by default; "every" disables queuing.
(define
hs-each
(fn
@@ -45,6 +22,12 @@
;; (hs-init thunk) — called at element boot time
(define meta (host-new "Object"))
;; Run an initializer function immediately.
;; (hs-init thunk) — called at element boot time
(define
hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler)))
;; ── Async / timing ──────────────────────────────────────────────
;; Wait for a duration in milliseconds.
@@ -68,13 +51,20 @@
hs-on
(fn
(target event-name handler)
(let
((wrapped (fn (event) (do (host-set! meta "caller" _hs-on-caller) (host-set! meta "owner" target) (let ((__hs-no-stop false)) (guard (e ((and (not (= event-name "exception")) (not (= event-name "error"))) (do (when (and (list? e) (= (first e) "hs-halt-default")) (set! __hs-no-stop true)) (when (not __hs-no-stop) (dom-dispatch target "exception" {:error e})))) (true (raise e))) (handler event)) (when (not __hs-no-stop) (host-call event "stopPropagation")))))))
(when
(not (nil? target))
(let
((unlisten (dom-listen target event-name wrapped))
(prev (or (dom-get-data target "hs-unlisteners") (list))))
(dom-set-data target "hs-unlisteners" (append prev (list unlisten)))
unlisten))))
((me-el (host-get (host-global "window") "__hs_current_me")))
(let
((wrapped (fn (event) (when (not (and me-el (not (hs-ref-eq me-el target)) (nil? (host-get me-el "parentElement")))) (do (host-set! meta "caller" _hs-on-caller) (host-set! meta "owner" target) (let ((__hs-no-stop false)) (guard (e ((and (not (= event-name "exception")) (not (= event-name "error"))) (do (when (and (list? e) (= (first e) "hs-halt-default")) (set! __hs-no-stop true)) (when (not __hs-no-stop) (dom-dispatch target "exception" {:error e})))) (true (raise e))) (handler event)) (when (not __hs-no-stop) (host-call event "stopPropagation"))))))))
(let
((unlisten (dom-listen target event-name wrapped))
(prev (or (dom-get-data target "hs-unlisteners") (list))))
(dom-set-data
target
"hs-unlisteners"
(append prev (list unlisten)))
unlisten))))))
;; Wait for CSS transitions/animations to settle on an element.
(define
@@ -279,7 +269,8 @@
(when with-cls (dom-remove-class target with-cls))))
(let
((attr-val (if (> (len extra) 0) (first extra) nil))
(with-val (if (> (len extra) 1) (nth extra 1) nil)))
(with-val
(if (> (len extra) 1) (nth extra 1) nil)))
(do
(for-each
(fn
@@ -503,7 +494,10 @@
((i (if (< idx 0) (+ n idx) idx)))
(cond
((or (< i 0) (>= i n)) target)
(true (concat (slice target 0 i) (slice target (+ i 1) n))))))
(true
(concat
(slice target 0 i)
(slice target (+ i 1) n))))))
(do
(when
target
@@ -603,6 +597,11 @@
((w (host-global "window")))
(if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-answer-alert
(fn
@@ -993,7 +992,7 @@
(host-get value "outerHTML")
(str value))))
(true nil)))))
;; Collection: joined by
(define
hs-sender
(fn
@@ -1210,7 +1209,14 @@
((= type-name "Array") (if (list? value) value (list value)))
((= type-name "HTML")
(cond
((list? value) (join "" (map (fn (x) (str x)) value)))
((list? value)
(join
""
(map
(fn
(x)
(if (hs-element? x) (host-get x "outerHTML") (str x)))
value)))
((hs-element? value) (host-get value "outerHTML"))
(true (str value))))
((= type-name "JSON")
@@ -1261,7 +1267,25 @@
((factor (pow 10 digits)))
(str (/ (floor (+ (* num factor) 0.5)) factor))))))
((= type-name "Selector") (str value))
((= type-name "Fragment") value)
((= type-name "Fragment")
(let
((frag (host-call (dom-document) "createDocumentFragment")))
(do
(for-each
(fn
(item)
(if
(hs-element? item)
(dom-append frag item)
(let
((tmp (dom-create-element "div")))
(do
(dom-set-inner-html tmp (str item))
(for-each
(fn (k) (dom-append frag k))
(host-get tmp "children"))))))
(if (list? value) value (list value)))
frag)))
((= type-name "Values") (hs-as-values value))
((= type-name "Keys")
(if
@@ -1599,10 +1623,14 @@
((ch (substring sel i (+ i 1))))
(cond
((= ch ".")
(do (flush!) (set! mode "class") (walk (+ i 1))))
(do
(flush!)
(set! mode "class")
(walk (+ i 1))))
((= ch "#")
(do (flush!) (set! mode "id") (walk (+ i 1))))
(true (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
(true
(do (set! cur (str cur ch)) (walk (+ i 1)))))))))
(walk 0)
(flush!)
{:tag tag :classes classes :id id}))))
@@ -1700,6 +1728,7 @@
hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
(define
hs-id=
(fn
@@ -1776,7 +1805,10 @@
((and (dict? a) (dict? b))
(let
((pos (host-call a "compareDocumentPosition" b)))
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(if
(number? pos)
(not (= 0 (mod (/ pos 4) 2)))
false)))
(true (< (str a) (str b))))))
(define
@@ -1897,7 +1929,10 @@
((and (dict? a) (dict? b))
(let
((pos (host-call a "compareDocumentPosition" b)))
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(if
(number? pos)
(not (= 0 (mod (/ pos 4) 2)))
false)))
(true (< (str a) (str b))))))
(define
@@ -1950,7 +1985,9 @@
(define
hs-morph-char
(fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
(fn
(s p)
(if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
(define
hs-morph-index-from
@@ -1978,7 +2015,10 @@
(q)
(let
((c (hs-morph-char s q)))
(if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q))))
(if
(and c (< (index-of stop c) 0))
(loop (+ q 1))
q))))
(let ((e (loop p))) (list (substring s p e) e))))
(define
@@ -2020,7 +2060,9 @@
(append
acc
(list
(list name (substring s (+ p4 1) close)))))))
(list
name
(substring s (+ p4 1) close)))))))
((= c2 "'")
(let
((close (hs-morph-index-from s "'" (+ p4 1))))
@@ -2030,7 +2072,9 @@
(append
acc
(list
(list name (substring s (+ p4 1) close)))))))
(list
name
(substring s (+ p4 1) close)))))))
(true
(let
((r2 (hs-morph-read-until s p4 " \t\n/>")))
@@ -2114,7 +2158,9 @@
(for-each
(fn
(c)
(when (> (string-length c) 0) (dom-add-class el c)))
(when
(> (string-length c) 0)
(dom-add-class el c)))
(split v " ")))
((and keep-id (= n "id")) nil)
(true (dom-set-attr el n v)))))
@@ -2215,7 +2261,8 @@
((parts (split resolved ":")))
(let
((prop (first parts))
(val (if (> (len parts) 1) (nth parts 1) nil)))
(val
(if (> (len parts) 1) (nth parts 1) nil)))
(cond
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
(let
@@ -2255,7 +2302,8 @@
((parts (split resolved ":")))
(let
((prop (first parts))
(val (if (> (len parts) 1) (nth parts 1) nil)))
(val
(if (> (len parts) 1) (nth parts 1) nil)))
(cond
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
(let
@@ -2360,10 +2408,14 @@
(if
(= depth 1)
j
(find-close (+ j 1) (- depth 1)))
(find-close
(+ j 1)
(- depth 1)))
(if
(= (nth raw j) "{")
(find-close (+ j 1) (+ depth 1))
(find-close
(+ j 1)
(+ depth 1))
(find-close (+ j 1) depth))))))
(let
((close (find-close start 1)))
@@ -2474,7 +2526,10 @@
(if
(= (len lst) 0)
-1
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(if
(= (first lst) item)
i
(idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0)))
(true
(let
@@ -2566,7 +2621,8 @@
(cond
((= end "hs-pick-end") n)
((= end "hs-pick-start") 0)
((and (number? end) (< end 0)) (max 0 (+ n end)))
((and (number? end) (< end 0))
(max 0 (+ n end)))
(true end))))
(cond
((string? col) (slice col s e))
@@ -2877,7 +2933,9 @@
((results (hs-query-all selector)))
(if
(and
(or (nil? results) (and (list? results) (= (len results) 0)))
(or
(nil? results)
(and (list? results) (= (len results) 0)))
(string? selector)
(> (len selector) 0)
(= (substring selector 0 1) "#"))
@@ -2902,21 +2960,27 @@
(if
fn
(let
((result (host-call-fn fn args)))
((result (host-call-fn-raising fn args)))
(if
(= (host-typeof result) "promise")
(let
((state (host-promise-state result)))
(= result "__hs_js_throw__")
(raise (host-take-js-throw))
(if
(= result "__hs_async_error__")
(raise "__hs_async_error__")
(if
(and state (= (host-get state "ok") false))
(do
(host-set!
(host-global "window")
"__hs_async_error"
(host-get state "value"))
(raise "__hs_async_error__"))
(if state (host-get state "value") result)))
result))
(= (host-typeof result) "promise")
(let
((state (host-promise-state result)))
(if
(and state (= (host-get state "ok") false))
(do
(host-set!
(host-global "window")
"__hs_async_error"
(host-get state "value"))
(raise "__hs_async_error__"))
(if state (host-get state "value") result)))
result))))
(let
((msg (str "'" fn-name "' is null")))
(host-set! (host-global "window") "_hs_null_error" msg)
@@ -3138,3 +3202,98 @@
(define hs-token-value (fn (tok) (dict-get tok :value)))
(define hs-token-op? (fn (tok) (dict-get tok :op)))
(define
hs-try-json-parse
(fn (data) (if (string? data) (guard (_e nil) (json-parse data)) nil)))
(define
hs-socket-normalise-url
(fn
(url)
(if
(or (starts-with? url "ws://") (starts-with? url "wss://"))
url
(let
((proto (host-get (host-global "location") "protocol"))
(host-str (host-get (host-global "location") "host")))
(let
((scheme (if (= proto "https:") "wss://" "ws://")))
(str scheme host-str url))))))
(define
hs-socket-bind-name!
(fn
(name-path wrapper)
(let
((win (host-global "window")))
(if
(= (len name-path) 1)
(host-set! win (first name-path) wrapper)
(do
(when
(nil? (host-get win (first name-path)))
(host-set! win (first name-path) (host-new "Object")))
(host-set!
(host-get win (first name-path))
(nth name-path 1)
wrapper))))))
(define
hs-socket-resolve-rpc!
(fn
(wrapper data)
(let
((iid (host-get data "iid")))
(when
(not (nil? iid))
(let
((pending (host-get wrapper "_pending")))
(when
(not (nil? pending))
(let
((entry (host-get pending iid)))
(when
(not (nil? entry))
(host-set! pending iid nil)
(if
(not (nil? (host-get data "throw")))
(host-call-fn
(host-get entry "reject")
(list (host-get data "throw")))
(host-call-fn
(host-get entry "resolve")
(list (host-get data "return"))))))))))))
(define
hs-socket-register!
(fn
(name-path url timeout on-message-handler json?)
(let
((norm-url (hs-socket-normalise-url url)))
(let
((wrapper (host-new "Object")))
(do
(host-set! wrapper "_url" norm-url)
(host-set! wrapper "_timeout" (if (nil? timeout) 0 timeout))
(host-set! wrapper "_pending" (host-new "Object"))
(host-set! wrapper "_closed" false)
(let
((ws (host-new "WebSocket" norm-url)))
(do
(host-set! wrapper "_ws" ws)
(let
((msg-handler (host-callback (fn (evt) (do (let ((parsed (hs-try-json-parse (host-get evt "data")))) (when (and (not (nil? parsed)) (not (nil? (host-get parsed "iid")))) (hs-socket-resolve-rpc! wrapper parsed))) (when (not (nil? on-message-handler)) (if json? (let ((data (hs-try-json-parse (host-get evt "data")))) (when (not (nil? data)) (on-message-handler data))) (on-message-handler evt))))))))
(do
(host-set! ws "onmessage" msg-handler)
(host-set! wrapper "_onmessage_handler" msg-handler)
(host-set!
ws
"onclose"
(host-callback
(fn (e) (host-set! wrapper "_closed" true))))
(host-call-fn
(host-global "_hsSetupSocket")
(list wrapper))
(hs-socket-bind-name! name-path wrapper)
wrapper)))))))))