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

hs: query targets, prolog hook, loop scripts, new plans, WASM regen

Browse Source 
Hyperscript compiler/runtime:
- query target support in set/fire/put commands
- hs-set-prolog-hook! / hs-prolog-hook / hs-prolog in runtime
- runtime log-capture cleanup

Scripts: sx-loops-up/down, sx-hs-e-up/down, sx-primitives-down
Plans: datalog, elixir, elm, go, koka, minikanren, ocaml, hs-bucket-f,
       designs (breakpoint, null-safety, step-limit, tell, cookies, eval,
       plugin-system)
lib/prolog/hs-bridge.sx: initial hook-based bridge draft
lib/common-lisp/tests/runtime.sx: CL runtime tests

WASM: regenerate sx_browser.bc.js from updated hs sources

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 09:19:56 +00:00
parent c311d4ebc4
commit 985671cd76
31 changed files with 16041 additions and 7056 deletions
Download Patch File Download Diff File Expand all files Collapse all files

207
lib/common-lisp/tests/runtime.sx Normal file
View File

@@ -0,0 +1,207 @@
;; lib/common-lisp/tests/runtime.sx — tests for CL runtime layer
(load "lib/common-lisp/runtime.sx")
(defsuite
"cl-types"
(deftest "cl-null? nil" (assert= true (cl-null? nil)))
(deftest "cl-null? false" (assert= false (cl-null? false)))
(deftest
"cl-consp? pair"
(assert= true (cl-consp? (list 1 2))))
(deftest "cl-consp? nil" (assert= false (cl-consp? nil)))
(deftest "cl-listp? nil" (assert= true (cl-listp? nil)))
(deftest
"cl-listp? list"
(assert= true (cl-listp? (list 1 2))))
(deftest "cl-atom? nil" (assert= true (cl-atom? nil)))
(deftest "cl-atom? pair" (assert= false (cl-atom? (list 1))))
(deftest "cl-integerp?" (assert= true (cl-integerp? 42)))
(deftest "cl-floatp?" (assert= true (cl-floatp? 3.14)))
(deftest
"cl-characterp?"
(assert= true (cl-characterp? (integer->char 65))))
(deftest "cl-stringp?" (assert= true (cl-stringp? "hello")))
(deftest "cl-symbolp?" (assert= true (cl-symbolp? (quote foo)))))
(defsuite
"cl-arithmetic"
(deftest "cl-mod" (assert= 1 (cl-mod 10 3)))
(deftest "cl-rem" (assert= 1 (cl-rem 10 3)))
(deftest
"cl-quotient"
(assert= 3 (cl-quotient 10 3)))
(deftest "cl-gcd" (assert= 4 (cl-gcd 12 8)))
(deftest "cl-lcm" (assert= 12 (cl-lcm 4 6)))
(deftest "cl-abs pos" (assert= 5 (cl-abs 5)))
(deftest "cl-abs neg" (assert= 5 (cl-abs -5)))
(deftest "cl-min" (assert= 2 (cl-min 2 7)))
(deftest "cl-max" (assert= 7 (cl-max 2 7)))
(deftest "cl-evenp? t" (assert= true (cl-evenp? 4)))
(deftest "cl-evenp? f" (assert= false (cl-evenp? 3)))
(deftest "cl-oddp? t" (assert= true (cl-oddp? 7)))
(deftest "cl-zerop?" (assert= true (cl-zerop? 0)))
(deftest "cl-plusp?" (assert= true (cl-plusp? 1)))
(deftest "cl-minusp?" (assert= true (cl-minusp? -1)))
(deftest "cl-signum pos" (assert= 1 (cl-signum 42)))
(deftest "cl-signum neg" (assert= -1 (cl-signum -7)))
(deftest "cl-signum zero" (assert= 0 (cl-signum 0))))
(defsuite
"cl-chars"
(deftest
"cl-char-code"
(assert= 65 (cl-char-code (integer->char 65))))
(deftest "cl-code-char" (assert= true (char? (cl-code-char 65))))
(deftest
"cl-char-upcase"
(assert=
(integer->char 65)
(cl-char-upcase (integer->char 97))))
(deftest
"cl-char-downcase"
(assert=
(integer->char 97)
(cl-char-downcase (integer->char 65))))
(deftest
"cl-alpha-char-p"
(assert= true (cl-alpha-char-p (integer->char 65))))
(deftest
"cl-digit-char-p"
(assert= true (cl-digit-char-p (integer->char 48))))
(deftest
"cl-char=?"
(assert=
true
(cl-char=? (integer->char 65) (integer->char 65))))
(deftest
"cl-char<?"
(assert=
true
(cl-char<? (integer->char 65) (integer->char 90))))
(deftest
"cl-char space"
(assert= (integer->char 32) cl-char-space))
(deftest
"cl-char newline"
(assert= (integer->char 10) cl-char-newline)))
(defsuite
"cl-format"
(deftest
"cl-format nil basic"
(assert= "hello" (cl-format nil "~a" "hello")))
(deftest
"cl-format nil number"
(assert= "42" (cl-format nil "~d" 42)))
(deftest
"cl-format nil hex"
(assert= "ff" (cl-format nil "~x" 255)))
(deftest
"cl-format nil template"
(assert= "x=3 y=4" (cl-format nil "x=~d y=~d" 3 4)))
(deftest "cl-format nil tilde" (assert= "a~b" (cl-format nil "a~~b"))))
(defsuite
"cl-gensym"
(deftest
"cl-gensym returns symbol"
(assert= "symbol" (type-of (cl-gensym))))
(deftest "cl-gensym unique" (assert= false (= (cl-gensym) (cl-gensym)))))
(defsuite
"cl-sets"
(deftest "cl-make-set empty" (assert= true (cl-set? (cl-make-set))))
(deftest
"cl-set-add/member"
(let
((s (cl-make-set)))
(do
(cl-set-add s 1)
(assert= true (cl-set-memberp s 1)))))
(deftest
"cl-set-memberp false"
(assert= false (cl-set-memberp (cl-make-set) 42)))
(deftest
"cl-list->set"
(let
((s (cl-list->set (list 1 2 3))))
(assert= true (cl-set-memberp s 2)))))
(defsuite
"cl-lists"
(deftest
"cl-nth 0"
(assert=
1
(cl-nth 0 (list 1 2 3))))
(deftest
"cl-nth 2"
(assert=
3
(cl-nth 2 (list 1 2 3))))
(deftest
"cl-last"
(assert=
(list 3)
(cl-last (list 1 2 3))))
(deftest
"cl-butlast"
(assert=
(list 1 2)
(cl-butlast (list 1 2 3))))
(deftest
"cl-nthcdr 1"
(assert=
(list 2 3)
(cl-nthcdr 1 (list 1 2 3))))
(deftest
"cl-assoc hit"
(assert=
(list "b" 2)
(cl-assoc "b" (list (list "a" 1) (list "b" 2)))))
(deftest
"cl-assoc miss"
(assert= nil (cl-assoc "z" (list (list "a" 1)))))
(deftest
"cl-getf hit"
(assert= 42 (cl-getf (list "x" 42 "y" 99) "x")))
(deftest "cl-getf miss" (assert= nil (cl-getf (list "x" 42) "z")))
(deftest
"cl-adjoin new"
(assert=
(list 0 1 2)
(cl-adjoin 0 (list 1 2))))
(deftest
"cl-adjoin dup"
(assert=
(list 1 2)
(cl-adjoin 1 (list 1 2))))
(deftest
"cl-flatten"
(assert=
(list 1 2 3 4)
(cl-flatten (list 1 (list 2 3) 4))))
(deftest
"cl-member hit"
(assert=
(list 2 3)
(cl-member 2 (list 1 2 3))))
(deftest
"cl-member miss"
(assert=
nil
(cl-member 9 (list 1 2 3)))))
(defsuite
"cl-radix"
(deftest "binary" (assert= "1010" (cl-format-binary 10)))
(deftest "octal" (assert= "17" (cl-format-octal 15)))
(deftest "hex" (assert= "ff" (cl-format-hex 255)))
(deftest "decimal" (assert= "42" (cl-format-decimal 42)))
(deftest
"n->s r16"
(assert= "1f" (cl-integer-to-string 31 16)))
(deftest
"s->n r16"
(assert= 31 (cl-string-to-integer "1f" 16))))

320
lib/hyperscript/compiler.sx
View File

@@ -48,6 +48,15 @@
prop
value))
(list (quote hs-query-all) (nth base-ast 1))))
((and (list? base-ast) (= (first base-ast) (quote query)))
(list
(quote dom-set-prop)
(list
(quote hs-named-target)
(nth base-ast 1)
(list (quote hs-query-first) (nth base-ast 1)))
prop
value))
((and (list? base-ast) (= (first base-ast) dot-sym) (let ((inner (nth base-ast 1))) (and (list? inner) (= (first inner) (quote query)) (let ((s (nth inner 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) "."))))))
(let
((inner (nth base-ast 1))
@@ -146,6 +155,14 @@
(nth prop-ast 1)
value)
(list (quote set!) (hs-to-sx target) value))))))
((= th (quote query))
(list
(quote hs-set-inner-html!)
(list
(quote hs-named-target)
(nth target 1)
(list (quote hs-query-first) (nth target 1)))
value))
(true (list (quote set!) (hs-to-sx target) value)))))))
(define
emit-on
@@ -274,17 +291,33 @@
((name (nth ast 1)) (rest-parts (rest (rest ast))))
(cond
((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict)))
(list
(quote dom-dispatch)
(hs-to-sx (nth ast 3))
name
(hs-to-sx (nth ast 2))))
(let
((tgt-ast (nth ast 3)))
(list
(quote dom-dispatch)
(if
(and (list? tgt-ast) (= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
name
(hs-to-sx (nth ast 2)))))
((= (len ast) 3)
(list
(quote dom-dispatch)
(hs-to-sx (nth ast 2))
name
(list (quote dict) "sender" (quote me))))
(let
((tgt-ast (nth ast 2)))
(list
(quote dom-dispatch)
(if
(and (list? tgt-ast) (= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
name
(list (quote dict) "sender" (quote me)))))
(true
(list
(quote dom-dispatch)
@@ -706,6 +739,33 @@
(quote fn)
(cons (quote me) (map make-symbol params))
(cons (quote do) (map hs-to-sx body)))))))
(define
hs-safe-obj
(fn
(obj-ast)
(if
(and (list? obj-ast) (= (first obj-ast) (quote ref)))
(list (quote host-global) (nth obj-ast 1))
(if
(and (list? obj-ast) (= (first obj-ast) dot-sym))
(let
((inner (nth obj-ast 1)) (prop (nth obj-ast 2)))
(list (quote host-get) (hs-safe-obj inner) prop))
(hs-to-sx obj-ast)))))
(define
hs-chain-name
(fn
(obj-ast)
(if
(and (list? obj-ast) (= (first obj-ast) (quote ref)))
(nth obj-ast 1)
(if
(and (list? obj-ast) (= (first obj-ast) dot-sym))
(str (hs-chain-name (nth obj-ast 1)) "." (nth obj-ast 2))
(if
(and (list? obj-ast) (= (first obj-ast) (quote query)))
(nth obj-ast 1)
nil)))))
(fn
(ast)
(cond
@@ -1226,12 +1286,21 @@
(if
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
(list
(quote for-each)
(quote let)
(list
(quote fn)
(list (quote _el))
(list (quote dom-add-class) (quote _el) (nth ast 1)))
(list (quote hs-query-all) (nth raw-tgt 1)))
(list
(quote _tgt)
(list (quote hs-query-named-all) (nth raw-tgt 1))))
(list
(quote for-each)
(list
(quote fn)
(list (quote _el))
(list
(quote dom-add-class)
(quote _el)
(nth ast 1)))
(quote _tgt)))
(list
(quote dom-add-class)
(hs-to-sx raw-tgt)
@@ -1244,14 +1313,20 @@
(nth ast 2)))
((= head (quote set-styles))
(let
((pairs (nth ast 1)) (tgt (hs-to-sx (nth ast 2))))
(cons
(quote do)
(map
(fn
(p)
(list (quote dom-set-style) tgt (first p) (nth p 1)))
pairs))))
((pairs (nth ast 1)) (tgt-ast (nth ast 2)))
(let
((tgt (if (and (list? tgt-ast) (= (first tgt-ast) (quote query))) (list (quote hs-named-target) (nth tgt-ast 1) (list (quote hs-query-first) (nth tgt-ast 1))) (hs-to-sx tgt-ast))))
(cons
(quote do)
(map
(fn
(p)
(list
(quote dom-set-style)
tgt
(first p)
(nth p 1)))
pairs)))))
((= head (quote multi-add-class))
(let
((target (hs-to-sx (nth ast 1)))
@@ -1349,15 +1424,21 @@
(if
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
(list
(quote for-each)
(quote let)
(list
(quote fn)
(list (quote _el))
(list
(quote dom-remove-class)
(quote _el)
(nth ast 1)))
(list (quote hs-query-all) (nth raw-tgt 1)))
(quote _tgt)
(list (quote hs-query-named-all) (nth raw-tgt 1))))
(list
(quote for-each)
(list
(quote fn)
(list (quote _el))
(list
(quote dom-remove-class)
(quote _el)
(nth ast 1)))
(quote _tgt)))
(list
(quote dom-remove-class)
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
@@ -1401,15 +1482,32 @@
((tgt (nth ast 3)))
(list
(quote hs-set-attr!)
(hs-to-sx tgt)
(if
(and (list? tgt) (= (first tgt) (quote query)))
(list
(quote hs-named-target)
(nth tgt 1)
(list (quote hs-query-first) (nth tgt 1)))
(hs-to-sx tgt))
(nth ast 1)
(hs-to-sx (nth ast 2)))))
((= head (quote remove-value))
(let
((val (hs-to-sx (nth ast 1))) (tgt (nth ast 2)))
((val (hs-to-sx (nth ast 1))) (raw-tgt (nth ast 2)))
(emit-set
tgt
(list (quote hs-remove-from!) val (hs-to-sx tgt)))))
raw-tgt
(list
(quote hs-remove-from!)
val
(if
(and
(list? raw-tgt)
(= (first raw-tgt) (quote query)))
(list
(quote hs-named-target)
(nth raw-tgt 1)
(list (quote hs-query-first) (nth raw-tgt 1)))
(hs-to-sx raw-tgt))))))
((= head (quote empty-target))
(let
((tgt (nth ast 1)))
@@ -1440,8 +1538,19 @@
(hs-to-sx (nth ast 2))))
((= head (quote remove-attr))
(let
((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2)))))
(list (quote dom-remove-attr) tgt (nth ast 1))))
((raw-tgt (nth ast 2)))
(list
(quote dom-remove-attr)
(if
(and
(list? raw-tgt)
(= (first raw-tgt) (quote query)))
(list
(quote hs-named-target)
(nth raw-tgt 1)
(list (quote hs-query-first) (nth raw-tgt 1)))
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)))
(nth ast 1))))
((= head (quote remove-css))
(let
((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2))))
@@ -1452,10 +1561,20 @@
(fn (p) (list (quote dom-set-style) tgt p ""))
props))))
((= head (quote toggle-class))
(list
(quote hs-toggle-class!)
(hs-to-sx (nth ast 2))
(nth ast 1)))
(let
((tgt-ast (nth ast 2)))
(list
(quote hs-toggle-class!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(nth ast 1))))
((= head (quote toggle-class-for))
(list
(quote do)
@@ -1510,11 +1629,21 @@
(hs-to-sx tgt-ast)
(hs-to-sx val-ast)))))
((= head (quote toggle-between))
(list
(quote hs-toggle-between!)
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2)))
(let
((tgt-ast (nth ast 3)))
(list
(quote hs-toggle-between!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(nth ast 1)
(nth ast 2))))
((= head (quote toggle-style))
(let
((raw-tgt (nth ast 2)))
@@ -1538,10 +1667,20 @@
(quote list)
(map hs-to-sx (slice ast 3 (len ast))))))
((= head (quote toggle-attr))
(list
(quote hs-toggle-attr!)
(hs-to-sx (nth ast 2))
(nth ast 1)))
(let
((tgt-ast (nth ast 2)))
(list
(quote hs-toggle-attr!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(nth ast 1))))
((= head (quote toggle-attr-between))
(list
(quote hs-toggle-attr-between!)
@@ -1575,7 +1714,22 @@
(emit-set
raw-tgt
(list (quote hs-put-at!) val pos (hs-to-sx raw-tgt))))
(true (list (quote hs-put!) val pos (hs-to-sx raw-tgt))))))
(true
(let
((tgt-ast raw-tgt))
(list
(quote hs-put!)
val
pos
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))))))))
((= head (quote if))
(if
(> (len ast) 3)
@@ -1651,12 +1805,22 @@
(detail (if (= (len ast) 4) (nth ast 2) nil)))
(list
(quote dom-dispatch)
(hs-to-sx tgt)
(let
((tgt-ast tgt))
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast)))
name
(if has-detail (hs-to-sx detail) nil))))
((= head (quote hide))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
@@ -1672,7 +1836,7 @@
(hs-to-sx when-cond))))))
((= head (quote show))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
@@ -1735,13 +1899,28 @@
((= head (quote call))
(let
((raw-fn (nth ast 1))
(fn-expr
(if
(string? raw-fn)
(make-symbol raw-fn)
(hs-to-sx raw-fn)))
(args (map hs-to-sx (rest (rest ast)))))
(cons fn-expr args)))
(if
(and (list? raw-fn) (= (first raw-fn) (quote ref)))
(let
((name (nth raw-fn 1)))
(list
(quote let)
(list
(list
(quote __hs-fn)
(list (quote host-global) name)))
(cons
(quote do)
(list
(list
(quote if)
(list (quote nil?) (quote __hs-fn))
(list (quote raise) (str "'" name "' is null"))
(cons (quote __hs-fn) args))))))
(let
((fn-expr (if (string? raw-fn) (make-symbol raw-fn) (hs-to-sx raw-fn))))
(cons fn-expr args)))))
((= head (quote return))
(let
((val (nth ast 1)))
@@ -1754,7 +1933,22 @@
((= head (quote throw))
(list (quote raise) (hs-to-sx (nth ast 1))))
((= head (quote settle))
(list (quote hs-settle) (quote me)))
(let
((raw-tgt (nth ast 1)))
(list
(quote hs-settle)
(if
(nil? raw-tgt)
(quote me)
(if
(and
(list? raw-tgt)
(= (first raw-tgt) (quote query)))
(list
(quote hs-named-target)
(nth raw-tgt 1)
(list (quote hs-query-first) (nth raw-tgt 1)))
(hs-to-sx raw-tgt))))))
((= head (quote go))
(list (quote hs-navigate!) (hs-to-sx (nth ast 1))))
((= head (quote ask))
@@ -1874,7 +2068,11 @@
((= head (quote install))
(cons (quote hs-install) (map hs-to-sx (rest ast))))
((= head (quote measure))
(list (quote hs-measure) (hs-to-sx (nth ast 1))))
(let
((raw-tgt (nth ast 1)))
(let
((compiled-tgt (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-named-target) (nth raw-tgt 1) (list (quote hs-query-first) (nth raw-tgt 1))) (hs-to-sx raw-tgt))))
(list (quote hs-measure) compiled-tgt))))
((= head (quote increment!))
(if
(= (len ast) 3)

11
lib/hyperscript/parser.sx
View File

@@ -2455,7 +2455,16 @@
((and (= typ "keyword") (= val "answer"))
(do (adv!) (parse-answer-cmd)))
((and (= typ "keyword") (= val "settle"))
(do (adv!) (list (quote settle))))
(do
(adv!)
(if
(or
(at-end?)
(and
(= (tp-type) "keyword")
(or (= (tp-val) "then") (= (tp-val) "end"))))
(list (quote settle))
(list (quote settle) (parse-expr)))))
((and (= typ "keyword") (= val "go"))
(do (adv!) (parse-go-cmd)))
((and (= typ "keyword") (= val "return"))

289
lib/hyperscript/runtime.sx
View File

@@ -12,37 +12,14 @@
;; 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
(target action)
(if (list? target) (for-each action target) (action target))))
;; Run an initializer function immediately.
;; (hs-init thunk) — called at element boot time
;; Register for every occurrence (no queuing — each fires independently).
;; Stock hyperscript queues by default; "every" disables queuing.
(define
hs-on
(fn
@@ -55,17 +32,17 @@
(dom-set-data target "hs-unlisteners" (append prev (list unlisten)))
unlisten))))
;; 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.
;; In hyperscript, wait is async-transparent — execution pauses.
;; Here we use perform/IO suspension for true pause semantics.
(define
hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler)))
;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires
(define
hs-on-intersection-attach!
(fn
@@ -81,15 +58,16 @@
(host-call observer "observe" target)
observer)))))
;; Wait for CSS transitions/animations to settle on an element.
;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires
(define hs-init (fn (thunk) (thunk)))
;; Wait for CSS transitions/animations to settle on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Toggle between two classes — exactly one is active at a time.
(begin
(define
hs-wait-for
@@ -102,21 +80,19 @@
(target event-name timeout-ms)
(perform (list (quote io-wait-event) target event-name timeout-ms)))))
;; Toggle between two classes — exactly one is active at a time.
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; ── DOM insertion ───────────────────────────────────────────────
;; Put content at a position relative to a target.
;; pos: "into" | "before" | "after"
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define
hs-toggle-between!
(fn
@@ -126,7 +102,9 @@
(do (dom-remove-class target cls1) (dom-add-class target cls2))
(do (dom-remove-class target cls2) (dom-add-class target cls1)))))
;; Find next sibling matching a selector (or any sibling).
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define
hs-toggle-style!
(fn
@@ -150,7 +128,7 @@
(dom-set-style target prop "hidden")
(dom-set-style target prop "")))))))
;; Find previous sibling matching a selector.
;; Find next sibling matching a selector (or any sibling).
(define
hs-toggle-style-between!
(fn
@@ -162,7 +140,7 @@
(dom-set-style target prop val2)
(dom-set-style target prop val1)))))
;; First element matching selector within a scope.
;; Find previous sibling matching a selector.
(define
hs-toggle-style-cycle!
(fn
@@ -183,7 +161,7 @@
(true (find-next (rest remaining))))))
(dom-set-style target prop (find-next vals)))))
;; Last element matching selector.
;; First element matching selector within a scope.
(define
hs-take!
(fn
@@ -206,7 +184,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
@@ -223,7 +202,7 @@
(dom-set-attr target name attr-val)
(dom-set-attr target name ""))))))))
;; First/last within a specific scope.
;; Last element matching selector.
(begin
(define
hs-element?
@@ -335,6 +314,7 @@
(dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target)))))))))
;; First/last within a specific scope.
(define
hs-add-to!
(fn
@@ -347,9 +327,6 @@
(append target (list value))))
(true (do (host-call target "push" value) target)))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define
hs-remove-from!
(fn
@@ -357,9 +334,15 @@
(if
(list? target)
(filter (fn (x) (not (= x value))) target)
(host-call target "splice" (host-call target "indexOf" value) 1))))
(host-call
target
"splice"
(host-call target "indexOf" value)
1))))
;; Repeat forever (until break — relies on exception/continuation).
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define
hs-splice-at!
(fn
@@ -372,7 +355,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
@@ -383,10 +369,7 @@
(host-call target "splice" i 1))))
target))))
;; ── Fetch ───────────────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
;; Repeat forever (until break — relies on exception/continuation).
(define
hs-index
(fn
@@ -398,10 +381,10 @@
((string? obj) (nth obj key))
(true (host-get obj key)))))
;; ── Type coercion ───────────────────────────────────────────────
;; ── Fetch ───────────────────────────────────────────────────────
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define
hs-put-at!
(fn
@@ -423,10 +406,10 @@
((= pos "start") (host-call target "unshift" value)))
target)))))))
;; ── Object creation ─────────────────────────────────────────────
;; ── Type coercion ───────────────────────────────────────────────
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(define
hs-dict-without
(fn
@@ -447,27 +430,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key)
out)))))
;; ── Behavior installation ───────────────────────────────────────
;; ── Object creation ─────────────────────────────────────────────
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
(define
hs-set-on!
(fn
(props target)
(for-each (fn (k) (host-set! target k (get props k))) (keys props))))
;; ── Behavior installation ───────────────────────────────────────
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
(define
hs-ask
(fn
@@ -476,11 +459,10 @@
((w (host-global "window")))
(if w (host-call w "prompt" msg) nil))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
(define
hs-answer
(fn
@@ -489,6 +471,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
@@ -643,25 +630,25 @@
(hs-query-all sel)
(host-call target "querySelectorAll" sel))))
(define
hs-list-set
(fn
(lst idx val)
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
(define
hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define
hs-query-first
(fn (sel) (host-call (host-global "document") "querySelector" sel)))
;; DOM query stub — sandbox returns empty list
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define
hs-query-last
(fn
@@ -669,11 +656,9 @@
(let
((all (dom-query-all (dom-body) sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; Method dispatch — obj.method(args)
;; DOM query stub — sandbox returns empty list
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
;; Method dispatch — obj.method(args)
(define
hs-last
(fn
@@ -681,7 +666,9 @@
(let
((all (dom-query-all scope sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; Property-based is — check obj.key truthiness
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define
hs-repeat-times
(fn
@@ -699,7 +686,7 @@
((= signal "hs-continue") (do-repeat (+ i 1)))
(true (do-repeat (+ i 1))))))))
(do-repeat 0)))
;; Array slicing (inclusive both ends)
;; Property-based is — check obj.key truthiness
(define
hs-repeat-forever
(fn
@@ -715,7 +702,7 @@
((= signal "hs-continue") (do-forever))
(true (do-forever))))))
(do-forever)))
;; Collection: sorted by
;; Array slicing (inclusive both ends)
(define
hs-repeat-while
(fn
@@ -728,7 +715,7 @@
((= signal "hs-break") nil)
((= signal "hs-continue") (hs-repeat-while cond-fn thunk))
(true (hs-repeat-while cond-fn thunk)))))))
;; Collection: sorted by descending
;; Collection: sorted by
(define
hs-repeat-until
(fn
@@ -740,7 +727,7 @@
((= signal "hs-continue")
(if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
;; Collection: split by
;; Collection: sorted by descending
(define
hs-for-each
(fn
@@ -760,7 +747,7 @@
((= signal "hs-continue") (do-loop (rest remaining)))
(true (do-loop (rest remaining))))))))
(do-loop items))))
;; Collection: joined by
;; Collection: split by
(begin
(define
hs-append
@@ -788,7 +775,7 @@
((hs-element? target)
(dom-insert-adjacent-html target "beforeend" (str value)))
(true nil)))))
;; Collection: joined by
(define
hs-sender
(fn
@@ -1310,10 +1297,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}))))
@@ -1398,6 +1389,7 @@
hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
(define
hs-eq-ignore-case
(fn (a b) (= (downcase (str a)) (downcase (str b)))))
@@ -1438,7 +1430,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
@@ -1540,7 +1535,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
@@ -1591,7 +1589,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
@@ -1619,7 +1619,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
@@ -1661,7 +1664,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))))
@@ -1671,7 +1676,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/>")))
@@ -1755,7 +1762,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)))))
@@ -1856,7 +1865,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
@@ -1895,7 +1905,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
@@ -1999,10 +2010,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)))
@@ -2093,7 +2108,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 nil))))
@@ -2179,7 +2197,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))
@@ -2466,6 +2485,50 @@
((nth entry 2) val)))
_hs-dom-watchers)))
(define hs-prolog-hook nil)
(define hs-set-prolog-hook! (fn (f) (set! hs-prolog-hook f)))
(define
prolog
(fn
(db goal)
(if
(nil? hs-prolog-hook)
(raise "prolog hook not installed")
(hs-prolog-hook db goal))))
(define
hs-null-error!
(fn (selector) (raise (str "'" selector "' is null"))))
(define
hs-named-target
(fn (selector value) (if (nil? value) (hs-null-error! selector) value)))
(define
hs-named-target-list
(fn
(selector values)
(if (nil? values) (hs-null-error! selector) values)))
(define
hs-query-named-all
(fn
(selector)
(let
((results (hs-query-all selector)))
(if
(and
(or
(nil? results)
(and (list? results) (= (len results) 0)))
(string? selector)
(> (len selector) 0)
(= (substring selector 0 1) "#"))
(hs-null-error! selector)
results))))
(define
hs-dom-is-ancestor?
(fn

21
lib/prolog/hs-bridge.sx Normal file
View File

@@ -0,0 +1,21 @@
;; lib/prolog/hs-bridge.sx — Prolog ↔ _hyperscript bridge
;;
;; Installs the prolog hook into the hyperscript runtime so that
;; hyperscript scripts can call:
;;
;; prolog(db, "goal(args)") → true (at least one solution)
;; → false (no solution)
;;
;; Usage:
;; (pl-install-hs-hook!) ;; call once at startup, after loading both libs
;;
;; Depends on:
;; lib/hyperscript/runtime.sx — provides hs-set-prolog-hook!
;; lib/prolog/runtime.sx — provides pl-query-one (Phase 3+)
(define
pl-install-hs-hook!
(fn
()
(hs-set-prolog-hook!
(fn (db goal) (not (= nil (pl-query-one db goal)))))))