giles
c923a34fa8
The sx-get links were doing full page refreshes because click handlers never attached. Root causes: VM frame management bug, missing primitives, CEK/VM type dispatch mismatch, and silent error swallowing. Fixes: - VM frame exhaustion: frames <- [] now properly pops to rest_frames - length primitive: add alias for len in OCaml primitives - call_sx_fn: use sx_call directly instead of eval_expr (CEK checks for type "lambda" but VmClosure reports "function") - Boot error surfacing: Sx.init() now has try/catch + failure summary - Callback error surfacing: catch-all handler for non-Eval_error exceptions - Silent JIT failures: log before CEK fallback instead of swallowing - vm→env sync: loadModule now calls sync_vm_to_env() - sx_build_bytecode MCP tool added for bytecode compilation Tests: 50 new tests across test-vm.sx and test-vm-primitives.sx covering nested VM calls, frame integrity, CEK bridge, primitive availability, cross-module symbol resolution, and callback dispatch. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
419 lines
9.4 KiB
Plaintext
419 lines
9.4 KiB
Plaintext
(define dom-document (fn () (host-global "document")))
|
|
|
|
(define dom-window (fn () (host-global "window")))
|
|
|
|
(define dom-body (fn () (host-get (dom-document) "body")))
|
|
|
|
(define dom-head (fn () (host-get (dom-document) "head")))
|
|
|
|
(define
|
|
dom-create-element
|
|
(fn
|
|
(tag &rest ns-arg)
|
|
(let
|
|
((ns (if (and ns-arg (not (empty? ns-arg))) (first ns-arg) nil)))
|
|
(if
|
|
ns
|
|
(host-call (dom-document) "createElementNS" ns tag)
|
|
(host-call (dom-document) "createElement" tag)))))
|
|
|
|
(define
|
|
create-text-node
|
|
(fn (s) (host-call (dom-document) "createTextNode" s)))
|
|
|
|
(define
|
|
create-fragment
|
|
(fn () (host-call (dom-document) "createDocumentFragment")))
|
|
|
|
(define
|
|
create-comment
|
|
(fn (text) (host-call (dom-document) "createComment" (or text ""))))
|
|
|
|
(define
|
|
dom-append
|
|
(fn
|
|
(parent child)
|
|
(when (and parent child) (host-call parent "appendChild" child))))
|
|
|
|
(define
|
|
dom-prepend
|
|
(fn
|
|
(parent child)
|
|
(when (and parent child) (host-call parent "prepend" child))))
|
|
|
|
(define
|
|
dom-insert-before
|
|
(fn
|
|
(parent child ref)
|
|
(when (and parent child) (host-call parent "insertBefore" child ref))))
|
|
|
|
(define
|
|
dom-insert-after
|
|
(fn
|
|
(ref node)
|
|
"Insert node after ref in the same parent."
|
|
(let
|
|
((parent (host-get ref "parentNode"))
|
|
(next (host-get ref "nextSibling")))
|
|
(when
|
|
parent
|
|
(if
|
|
next
|
|
(host-call parent "insertBefore" node next)
|
|
(host-call parent "appendChild" node))))))
|
|
|
|
(define dom-remove (fn (el) (when el (host-call el "remove"))))
|
|
|
|
(define
|
|
dom-is-active-element?
|
|
(fn
|
|
(el)
|
|
(let
|
|
((active (host-get (dom-document) "activeElement")))
|
|
(if (and active el) (identical? el active) false))))
|
|
|
|
(define
|
|
dom-is-input-element?
|
|
(fn
|
|
(el)
|
|
(let
|
|
((tag (upper (or (dom-tag-name el) ""))))
|
|
(or (= tag "INPUT") (= tag "TEXTAREA") (= tag "SELECT")))))
|
|
|
|
(define
|
|
dom-is-child-of?
|
|
(fn (child parent) (and child parent (host-call parent "contains" child))))
|
|
|
|
(define
|
|
dom-attr-list
|
|
(fn
|
|
(el)
|
|
(let
|
|
((attrs (host-get el "attributes")) (result (list)))
|
|
(when
|
|
attrs
|
|
(let
|
|
((n (host-get attrs "length")))
|
|
(let
|
|
loop
|
|
((i 0))
|
|
(when
|
|
(< i n)
|
|
(let
|
|
((attr (host-call attrs "item" i)))
|
|
(append!
|
|
result
|
|
(list (host-get attr "name") (host-get attr "value"))))
|
|
(loop (+ i 1))))))
|
|
result)))
|
|
|
|
(define
|
|
dom-remove-child
|
|
(fn
|
|
(parent child)
|
|
(when (and parent child) (host-call parent "removeChild" child))))
|
|
|
|
(define
|
|
dom-replace-child
|
|
(fn
|
|
(parent new-child old-child)
|
|
(when
|
|
(and parent new-child old-child)
|
|
(host-call parent "replaceChild" new-child old-child))))
|
|
|
|
(define
|
|
dom-clone
|
|
(fn (node deep) (host-call node "cloneNode" (if (nil? deep) true deep))))
|
|
|
|
(define
|
|
dom-query
|
|
(fn
|
|
(root-or-sel &rest rest)
|
|
(if
|
|
(empty? rest)
|
|
(host-call (dom-document) "querySelector" root-or-sel)
|
|
(host-call root-or-sel "querySelector" (first rest)))))
|
|
|
|
(define
|
|
dom-query-all
|
|
(fn
|
|
(root sel)
|
|
"Query DOM and return an SX list (not a host NodeList)."
|
|
(let
|
|
((node-list (if (nil? sel) (host-call (dom-document) "querySelectorAll" root) (host-call root "querySelectorAll" sel))))
|
|
(if
|
|
(nil? node-list)
|
|
(list)
|
|
(let
|
|
((n (host-get node-list "length")) (result (list)))
|
|
(let
|
|
loop
|
|
((i 0))
|
|
(when
|
|
(< i n)
|
|
(append! result (host-call node-list "item" i))
|
|
(loop (+ i 1))))
|
|
result)))))
|
|
|
|
(define
|
|
dom-query-by-id
|
|
(fn (id) (host-call (dom-document) "getElementById" id)))
|
|
|
|
(define dom-closest (fn (el sel) (when el (host-call el "closest" sel))))
|
|
|
|
(define
|
|
dom-matches?
|
|
(fn
|
|
(el sel)
|
|
(if (and el (host-get el "matches")) (host-call el "matches" sel) false)))
|
|
|
|
(define
|
|
dom-get-attr
|
|
(fn
|
|
(el name)
|
|
(if
|
|
(and el (host-get el "getAttribute"))
|
|
(let ((v (host-call el "getAttribute" name))) (if (nil? v) nil v))
|
|
nil)))
|
|
|
|
(define
|
|
dom-set-attr
|
|
(fn
|
|
(el name val)
|
|
(when
|
|
(and el (host-get el "setAttribute"))
|
|
(host-call el "setAttribute" name val))))
|
|
|
|
(define
|
|
dom-remove-attr
|
|
(fn
|
|
(el name)
|
|
(when
|
|
(and el (host-get el "removeAttribute"))
|
|
(host-call el "removeAttribute" name))))
|
|
|
|
(define
|
|
dom-has-attr?
|
|
(fn
|
|
(el name)
|
|
(if
|
|
(and el (host-get el "hasAttribute"))
|
|
(host-call el "hasAttribute" name)
|
|
false)))
|
|
|
|
(define
|
|
dom-add-class
|
|
(fn (el cls) (when el (host-call (host-get el "classList") "add" cls))))
|
|
|
|
(define
|
|
dom-remove-class
|
|
(fn
|
|
(el cls)
|
|
(when el (host-call (host-get el "classList") "remove" cls))))
|
|
|
|
(define
|
|
dom-has-class?
|
|
(fn
|
|
(el cls)
|
|
(if el (host-call (host-get el "classList") "contains" cls) false)))
|
|
|
|
(define dom-text-content (fn (el) (host-get el "textContent")))
|
|
|
|
(define dom-set-text-content (fn (el val) (host-set! el "textContent" val)))
|
|
|
|
(define dom-inner-html (fn (el) (host-get el "innerHTML")))
|
|
|
|
(define dom-set-inner-html (fn (el val) (host-set! el "innerHTML" val)))
|
|
|
|
(define dom-outer-html (fn (el) (host-get el "outerHTML")))
|
|
|
|
(define
|
|
dom-insert-adjacent-html
|
|
(fn (el position html) (host-call el "insertAdjacentHTML" position html)))
|
|
|
|
(define dom-get-style (fn (el prop) (host-get (host-get el "style") prop)))
|
|
|
|
(define
|
|
dom-set-style
|
|
(fn
|
|
(el prop val)
|
|
(host-call (host-get el "style") "setProperty" prop val)))
|
|
|
|
(define dom-get-prop (fn (el name) (host-get el name)))
|
|
|
|
(define dom-set-prop (fn (el name val) (host-set! el name val)))
|
|
|
|
(define
|
|
dom-tag-name
|
|
(fn (el) (if el (lower (or (host-get el "tagName") "")) "")))
|
|
|
|
(define dom-node-type (fn (el) (host-get el "nodeType")))
|
|
|
|
(define dom-node-name (fn (el) (host-get el "nodeName")))
|
|
|
|
(define dom-id (fn (el) (host-get el "id")))
|
|
|
|
(define dom-parent (fn (el) (host-get el "parentNode")))
|
|
|
|
(define dom-first-child (fn (el) (host-get el "firstChild")))
|
|
|
|
(define dom-next-sibling (fn (el) (host-get el "nextSibling")))
|
|
|
|
(define
|
|
dom-child-list
|
|
(fn
|
|
(el)
|
|
"Return child nodes as an SX list."
|
|
(if
|
|
el
|
|
(let
|
|
((nl (host-get el "childNodes"))
|
|
(n (host-get nl "length"))
|
|
(result (list)))
|
|
(let
|
|
loop
|
|
((i 0))
|
|
(when
|
|
(< i n)
|
|
(append! result (host-call nl "item" i))
|
|
(loop (+ i 1))))
|
|
result)
|
|
(list))))
|
|
|
|
(define dom-is-fragment? (fn (el) (= (host-get el "nodeType") 11)))
|
|
|
|
(define
|
|
dom-child-nodes
|
|
(fn
|
|
(el)
|
|
"Return child nodes as an SX list."
|
|
(if
|
|
el
|
|
(let
|
|
((nl (host-get el "childNodes"))
|
|
(n (host-get nl "length"))
|
|
(result (list)))
|
|
(let
|
|
loop
|
|
((i 0))
|
|
(when
|
|
(< i n)
|
|
(append! result (host-call nl "item" i))
|
|
(loop (+ i 1))))
|
|
result)
|
|
(list))))
|
|
|
|
(define
|
|
dom-remove-children-after
|
|
(fn
|
|
(marker)
|
|
"Remove all siblings after marker node."
|
|
(let
|
|
((parent (dom-parent marker)))
|
|
(when
|
|
parent
|
|
(let
|
|
loop
|
|
()
|
|
(let
|
|
((next (dom-next-sibling marker)))
|
|
(when next (host-call parent "removeChild" next) (loop))))))))
|
|
|
|
(define dom-focus (fn (el) (when el (host-call el "focus"))))
|
|
|
|
(define
|
|
dom-parse-html
|
|
(fn
|
|
(html)
|
|
(let
|
|
((parser (host-new "DOMParser"))
|
|
(doc (host-call parser "parseFromString" html "text/html")))
|
|
(host-get (host-get doc "body") "childNodes"))))
|
|
|
|
(define
|
|
dom-listen
|
|
(fn
|
|
(el event-name handler)
|
|
(let
|
|
((cb (host-callback handler)))
|
|
(host-call el "addEventListener" event-name cb)
|
|
(fn () (host-call el "removeEventListener" event-name cb)))))
|
|
|
|
(define
|
|
dom-add-listener
|
|
(fn
|
|
(el event-name handler &rest opts)
|
|
(let
|
|
((cb (host-callback handler)))
|
|
(if
|
|
(and opts (not (empty? opts)))
|
|
(host-call el "addEventListener" event-name cb (first opts))
|
|
(host-call el "addEventListener" event-name cb))
|
|
(fn () (host-call el "removeEventListener" event-name cb)))))
|
|
|
|
(define
|
|
dom-dispatch
|
|
(fn
|
|
(el event-name detail)
|
|
(let
|
|
((evt (host-new "CustomEvent" event-name (dict "detail" detail "bubbles" true))))
|
|
(host-call el "dispatchEvent" evt))))
|
|
|
|
(define event-detail (fn (evt) (host-get evt "detail")))
|
|
|
|
(define prevent-default (fn (e) (when e (host-call e "preventDefault"))))
|
|
|
|
(define stop-propagation (fn (e) (when e (host-call e "stopPropagation"))))
|
|
|
|
(define
|
|
event-modifier-key?
|
|
(fn
|
|
(e)
|
|
(and
|
|
e
|
|
(or
|
|
(host-get e "ctrlKey")
|
|
(host-get e "metaKey")
|
|
(host-get e "shiftKey")
|
|
(host-get e "altKey")))))
|
|
|
|
(define
|
|
element-value
|
|
(fn
|
|
(el)
|
|
(if
|
|
(and el (not (nil? (host-get el "value"))))
|
|
(host-get el "value")
|
|
nil)))
|
|
|
|
(define
|
|
error-message
|
|
(fn
|
|
(e)
|
|
(if (and e (host-get e "message")) (host-get e "message") (str e))))
|
|
|
|
(define
|
|
dom-get-data
|
|
(fn
|
|
(el key)
|
|
(let
|
|
((store (host-get el "__sx_data")))
|
|
(if store (host-get store key) nil))))
|
|
|
|
(define
|
|
dom-set-data
|
|
(fn
|
|
(el key val)
|
|
(when
|
|
(not (host-get el "__sx_data"))
|
|
(host-set! el "__sx_data" (dict)))
|
|
(host-set! (host-get el "__sx_data") key val)))
|
|
|
|
(define
|
|
dom-append-to-head
|
|
(fn (el) (when (dom-head) (host-call (dom-head) "appendChild" el))))
|
|
|
|
(define
|
|
set-document-title
|
|
(fn (title) (host-set! (dom-document) "title" title)))
|