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

HS: return/guard, repeat while/until, if-then fix, script extraction

Browse Source 
Parser: if-then consumes 'then' keyword before parsing then-body.
Compiler: return→raise, def→guard, repeat while/until dispatch.
Runtime: hs-repeat-while, hs-repeat-until.
Test gen: script block extraction for def functions.
repeat suite: 10→13/30.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-16 21:33:55 +00:00
parent 97818c6de1
commit 76f7e3b68a
9 changed files with 396 additions and 1568 deletions
Download Patch File Download Diff File Expand all files Collapse all files

64
shared/static/wasm/sx/hs-compiler.sx
View File

@@ -237,6 +237,20 @@
(quote hs-repeat-times)
mode
(list (quote fn) (list) body)))
((and (list? mode) (= (first mode) (quote while)))
(let
((cond-expr (hs-to-sx (nth mode 1))))
(list
(quote hs-repeat-while)
(list (quote fn) (list) cond-expr)
(list (quote fn) (list) body))))
((and (list? mode) (= (first mode) (quote until)))
(let
((cond-expr (hs-to-sx (nth mode 1))))
(list
(quote hs-repeat-until)
(list (quote fn) (list) cond-expr)
(list (quote fn) (list) body))))
(true
(list
(quote hs-repeat-times)
@@ -1035,7 +1049,15 @@
((fn-expr (hs-to-sx (nth ast 1)))
(args (map hs-to-sx (nth ast 2))))
(cons fn-expr args)))
((= head (quote return)) (hs-to-sx (nth ast 1)))
((= head (quote return))
(let
((val (nth ast 1)))
(if
(nil? val)
(list (quote raise) (list (quote list) "hs-return" nil))
(list
(quote raise)
(list (quote list) "hs-return" (hs-to-sx val))))))
((= head (quote throw))
(list (quote raise) (hs-to-sx (nth ast 1))))
((= head (quote settle))
@@ -1106,13 +1128,41 @@
(quote hs-init)
(list (quote fn) (list) (hs-to-sx (nth ast 1)))))
((= head (quote def))
(list
(quote define)
(make-symbol (nth ast 1))
(let
((body (hs-to-sx (nth ast 3)))
(params
(map
(fn
(p)
(if
(and (list? p) (= (first p) (quote ref)))
(make-symbol (nth p 1))
(make-symbol p)))
(nth ast 2))))
(list
(quote fn)
(map make-symbol (nth ast 2))
(hs-to-sx (nth ast 3)))))
(quote define)
(make-symbol (nth ast 1))
(list
(quote fn)
params
(list
(quote guard)
(list
(quote _e)
(list
(quote true)
(list
(quote if)
(list
(quote and)
(list (quote list?) (quote _e))
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body)))))
((= head (quote behavior)) (emit-behavior ast))
((= head (quote sx-eval))
(let

2
shared/static/wasm/sx/hs-parser.sx
View File

@@ -1041,7 +1041,7 @@
(let
((cnd (parse-expr)))
(let
((then-body (parse-cmd-list)))
((then-body (do (match-kw "then") (parse-cmd-list))))
(let
((else-body (if (or (match-kw "else") (match-kw "otherwise")) (parse-cmd-list) nil)))
(match-kw "end")

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

@@ -275,6 +275,12 @@
(define do-forever (fn () (thunk) (do-forever)))
(do-forever)))
(define
hs-repeat-while
(fn
(cond-fn thunk)
(when (cond-fn) (thunk) (hs-repeat-while cond-fn thunk))))
(define
hs-fetch
(fn
@@ -426,6 +432,10 @@
(dom-set-style target prop (str to-val))
(when duration (hs-settle target))))
(define
hs-type-check
(fn
@@ -446,37 +456,33 @@
(= (host-typeof value) "text")))
(true (= (host-typeof value) (downcase type-name)))))))
(define
hs-type-check-strict
(fn
(value type-name)
(if (nil? value) false (hs-type-check value type-name))))
(define
hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define
hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
;; DOM query stub — sandbox returns empty list
(define
hs-eq-ignore-case
(fn (a b) (= (downcase (str a)) (downcase (str b)))))
;; DOM query stub — sandbox returns empty list
;; Method dispatch — obj.method(args)
(define
hs-starts-with-ic?
(fn (str prefix) (starts-with? (downcase str) (downcase prefix))))
;; Method dispatch — obj.method(args)
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define
hs-contains-ignore-case?
(fn
(haystack needle)
(contains? (downcase (str haystack)) (downcase (str needle)))))
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
;; Property-based is — check obj.key truthiness
(define
hs-falsy?
(fn
@@ -488,7 +494,7 @@
((and (list? v) (= (len v) 0)) true)
((= v 0) true)
(true false))))
;; Property-based is — check obj.key truthiness
;; Array slicing (inclusive both ends)
(define
hs-matches?
(fn
@@ -499,7 +505,7 @@
((= (host-typeof target) "element")
(if (string? pattern) (host-call target "matches" pattern) false))
(true false))))
;; Array slicing (inclusive both ends)
;; Collection: sorted by
(define
hs-contains?
(fn
@@ -519,9 +525,9 @@
true
(hs-contains? (rest collection) item)))))
(true false))))
;; Collection: sorted by
(define precedes? (fn (a b) (< (str a) (str b))))
;; Collection: sorted by descending
(define precedes? (fn (a b) (< (str a) (str b))))
;; Collection: split by
(define
hs-empty?
(fn
@@ -532,7 +538,7 @@
((list? v) (= (len v) 0))
((dict? v) (= (len (keys v)) 0))
(true false))))
;; Collection: split by
;; Collection: joined by
(define
hs-empty-target!
(fn
@@ -557,7 +563,7 @@
((children (host-call target "querySelectorAll" "input, textarea, select")))
(for-each (fn (el) (hs-empty-target! el)) children)))
(true (dom-set-inner-html target ""))))))))
;; Collection: joined by
(define
hs-open!
(fn