Fix type-check-strict compiler match + deploy HS to WASM

- Compiler match for type-check-strict was still using old name type-check!
- Deploy updated HS source files to shared/static/wasm/sx/
- Sandbox runner validates 16/16 hard cases pass with cek-eval
  (no runtime let-binding hacks needed in WASM context)

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
2026-04-08 21:25:23 +00:00
parent 7a1af7a80a
commit 67d2f32512
5 changed files with 2341 additions and 6 deletions

View File

@@ -597,7 +597,7 @@
(quote hs-type-check) (quote hs-type-check)
(hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 1))
(nth ast 2))) (nth ast 2)))
((= head (quote type-check!)) ((= head (quote type-check-strict))
(list (list
(quote hs-type-check-strict) (quote hs-type-check-strict)
(hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 1))

View File

@@ -0,0 +1,629 @@
;; _hyperscript compiler — AST → SX expressions
;;
;; Input: AST from hs-parse (list structures)
;; Output: SX expressions targeting web/lib/dom.sx primitives
;;
;; Usage:
;; (hs-to-sx (hs-compile "on click add .active to me"))
;; → (hs-on me "click" (fn (event) (dom-add-class me "active")))
(define
hs-to-sx
(let
((dot-sym (make-symbol ".")) (pct-sym (make-symbol "%")))
(define emit-target (fn (ast) (hs-to-sx ast)))
(define
emit-set
(fn
(target value)
(if
(not (list? target))
(list (quote set!) target value)
(let
((th (first target)))
(cond
((= th dot-sym)
(list
(quote dom-set-prop)
(hs-to-sx (nth target 1))
(nth target 2)
value))
((= th (quote attr))
(list
(quote dom-set-attr)
(hs-to-sx (nth target 2))
(nth target 1)
value))
((= th (quote style))
(list
(quote dom-set-style)
(hs-to-sx (nth target 2))
(nth target 1)
value))
((= th (quote ref))
(list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote local))
(list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote me))
(list (quote dom-set-inner-html) (quote me) value))
((= th (quote it)) (list (quote set!) (quote it) value))
(true (list (quote set!) (hs-to-sx target) value)))))))
(define
emit-on
(fn
(ast)
(let
((parts (rest ast)))
(let
((event-name (first parts)))
(define
scan-on
(fn
(items source filter every?)
(cond
((<= (len items) 1)
(let
((body (if (> (len items) 0) (first items) nil)))
(let
((target (if source (hs-to-sx source) (quote me))))
(let
((handler (list (quote fn) (list (quote event)) (hs-to-sx body))))
(if
every?
(list
(quote hs-on-every)
target
event-name
handler)
(list (quote hs-on) target event-name handler))))))
((= (first items) :from)
(scan-on
(rest (rest items))
(nth items 1)
filter
every?))
((= (first items) :filter)
(scan-on
(rest (rest items))
source
(nth items 1)
every?))
((= (first items) :every)
(scan-on (rest (rest items)) source filter true))
(true (scan-on (rest items) source filter every?)))))
(scan-on (rest parts) nil nil false)))))
(define
emit-send
(fn
(ast)
(let
((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))))
((= (len ast) 3)
(list (quote dom-dispatch) (hs-to-sx (nth ast 2)) name nil))
(true (list (quote dom-dispatch) (quote me) name nil))))))
(define
emit-repeat
(fn
(ast)
(let
((mode (nth ast 1)) (body (hs-to-sx (nth ast 2))))
(cond
((and (list? mode) (= (first mode) (quote forever)))
(list
(quote hs-repeat-forever)
(list (quote fn) (list) body)))
((and (list? mode) (= (first mode) (quote times)))
(list
(quote hs-repeat-times)
(hs-to-sx (nth mode 1))
(list (quote fn) (list) body)))
((number? mode)
(list
(quote hs-repeat-times)
mode
(list (quote fn) (list) body)))
(true
(list
(quote hs-repeat-times)
(hs-to-sx mode)
(list (quote fn) (list) body)))))))
(define
emit-for
(fn
(ast)
(let
((var-name (nth ast 1))
(collection (hs-to-sx (nth ast 2)))
(body (hs-to-sx (nth ast 3))))
(if
(and (> (len ast) 4) (= (nth ast 4) :index))
(list
(quote for-each)
(list
(quote fn)
(list (make-symbol var-name) (make-symbol (nth ast 5)))
body)
collection)
(list
(quote for-each)
(list (quote fn) (list (make-symbol var-name)) body)
collection)))))
(define
emit-wait-for
(fn
(ast)
(let
((event-name (nth ast 1)))
(if
(and (> (len ast) 2) (= (nth ast 2) :from))
(list (quote hs-wait-for) (hs-to-sx (nth ast 3)) event-name)
(list (quote hs-wait-for) (quote me) event-name)))))
(define
emit-transition
(fn
(ast)
(let
((prop (nth ast 1)) (value (hs-to-sx (nth ast 2))))
(if
(= (len ast) 5)
(list
(quote hs-transition)
(hs-to-sx (nth ast 4))
prop
value
(nth ast 3))
(list
(quote hs-transition)
(hs-to-sx (nth ast 3))
prop
value
nil)))))
(define
emit-make
(fn
(ast)
(if
(= (len ast) 3)
(list
(quote let)
(list
(list
(make-symbol (nth ast 2))
(list (quote hs-make) (nth ast 1))))
(make-symbol (nth ast 2)))
(list (quote hs-make) (nth ast 1)))))
(define
emit-inc
(fn
(expr tgt-override)
(let
((t (hs-to-sx expr)))
(if
(and (list? expr) (= (first expr) (quote attr)))
(let
((el (if tgt-override (hs-to-sx tgt-override) (hs-to-sx (nth expr 2)))))
(list
(quote dom-set-attr)
el
(nth expr 1)
(list
(quote +)
(list
(quote parse-number)
(list (quote dom-get-attr) el (nth expr 1)))
1)))
(list (quote set!) t (list (quote +) t 1))))))
(define
emit-dec
(fn
(expr tgt-override)
(let
((t (hs-to-sx expr)))
(if
(and (list? expr) (= (first expr) (quote attr)))
(let
((el (if tgt-override (hs-to-sx tgt-override) (hs-to-sx (nth expr 2)))))
(list
(quote dom-set-attr)
el
(nth expr 1)
(list
(quote -)
(list
(quote parse-number)
(list (quote dom-get-attr) el (nth expr 1)))
1)))
(list (quote set!) t (list (quote -) t 1))))))
(define
emit-behavior
(fn
(ast)
(let
((name (nth ast 1)) (params (nth ast 2)) (body (nth ast 3)))
(list
(quote define)
(make-symbol name)
(list
(quote fn)
(cons (quote me) (map make-symbol params))
(cons (quote do) (map hs-to-sx body)))))))
(fn
(ast)
(cond
((nil? ast) nil)
((number? ast) ast)
((string? ast) ast)
((boolean? ast) ast)
((not (list? ast)) ast)
(true
(let
((head (first ast)))
(cond
((= head (quote null-literal)) nil)
((= head (quote me)) (quote me))
((= head (quote it)) (quote it))
((= head (quote event)) (quote event))
((= head dot-sym)
(let
((target (hs-to-sx (nth ast 1))) (prop (nth ast 2)))
(cond
((= prop "first") (list (quote hs-first) target))
((= prop "last") (list (quote hs-last) target))
(true (list (quote get) target prop)))))
((= head (quote ref)) (make-symbol (nth ast 1)))
((= head (quote query))
(list (quote dom-query) (nth ast 1)))
((= head (quote attr))
(list
(quote dom-get-attr)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote style))
(list
(quote dom-get-style)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote local)) (make-symbol (nth ast 1)))
((= head (quote array))
(cons (quote list) (map hs-to-sx (rest ast))))
((= head (quote not))
(list (quote not) (hs-to-sx (nth ast 1))))
((= head (quote no))
(list (quote hs-falsy?) (hs-to-sx (nth ast 1))))
((= head (quote and))
(list
(quote and)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote or))
(list
(quote or)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote =))
(list
(quote =)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote +))
(list
(quote hs-add)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote -))
(list
(quote -)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote *))
(list
(quote *)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote /))
(list
(quote /)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head pct-sym)
(list
(quote modulo)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote empty?))
(list (quote hs-empty?) (hs-to-sx (nth ast 1))))
((= head (quote exists?))
(list
(quote not)
(list (quote nil?) (hs-to-sx (nth ast 1)))))
((= head (quote matches?))
(list
(quote hs-matches?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote hs-contains?))
(list
(quote hs-contains?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote as))
(list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote in?))
(list
(quote hs-contains?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote of))
(let
((prop (hs-to-sx (nth ast 1)))
(target (hs-to-sx (nth ast 2))))
(cond
((= prop (quote first)) (list (quote first) target))
((= prop (quote last)) (list (quote last) target))
(true (list (quote get) target prop)))))
((= head "!=")
(list
(quote not)
(list
(quote =)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head "<")
(list
(quote <)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head ">")
(list
(quote >)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head "<=")
(list
(quote <=)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head ">=")
(list
(quote >=)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote closest))
(list
(quote dom-closest)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote next))
(list (quote hs-next) (hs-to-sx (nth ast 2)) (nth ast 1)))
((= head (quote previous))
(list
(quote hs-previous)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote first))
(if
(> (len ast) 2)
(list
(quote hs-first)
(hs-to-sx (nth ast 2))
(nth ast 1))
(list (quote hs-query-first) (nth ast 1))))
((= head (quote last))
(if
(> (len ast) 2)
(list (quote hs-last) (hs-to-sx (nth ast 2)) (nth ast 1))
(list (quote hs-query-last) (nth ast 1))))
((= head (quote add-class))
(list
(quote dom-add-class)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote remove-class))
(list
(quote dom-remove-class)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-class))
(list
(quote hs-toggle-class!)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-between))
(list
(quote hs-toggle-between!)
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2)))
((= head (quote set!))
(emit-set (nth ast 1) (hs-to-sx (nth ast 2))))
((= head (quote put!))
(list
(quote hs-put!)
(hs-to-sx (nth ast 1))
(nth ast 2)
(hs-to-sx (nth ast 3))))
((= head (quote if))
(if
(> (len ast) 3)
(list
(quote if)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 3)))
(list
(quote when)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote do))
(cons (quote do) (map hs-to-sx (rest ast))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast))
((= head (quote log))
(list (quote log) (hs-to-sx (nth ast 1))))
((= head (quote send)) (emit-send ast))
((= head (quote trigger))
(list
(quote dom-dispatch)
(hs-to-sx (nth ast 2))
(nth ast 1)
nil))
((= head (quote hide))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 1))
"display"
"none"))
((= head (quote show))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 1))
"display"
""))
((= head (quote transition)) (emit-transition ast))
((= head (quote repeat)) (emit-repeat ast))
((= head (quote fetch))
(list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote call))
(cons
(make-symbol (nth ast 1))
(map hs-to-sx (rest (rest ast)))))
((= head (quote return)) (hs-to-sx (nth ast 1)))
((= head (quote throw))
(list (quote raise) (hs-to-sx (nth ast 1))))
((= head (quote settle))
(list (quote hs-settle) (quote me)))
((= head (quote go))
(list (quote hs-navigate!) (hs-to-sx (nth ast 1))))
((= head (quote append!))
(list
(quote dom-append)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote tell))
(list
(quote let)
(list (list (quote me) (hs-to-sx (nth ast 1))))
(hs-to-sx (nth ast 2))))
((= head (quote for)) (emit-for ast))
((= head (quote take))
(list (quote hs-take!) (hs-to-sx (nth ast 2)) (nth ast 1)))
((= head (quote make)) (emit-make ast))
((= 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))))
((= head (quote increment!))
(emit-inc
(nth ast 1)
(if (> (len ast) 2) (nth ast 2) nil)))
((= head (quote decrement!))
(emit-dec
(nth ast 1)
(if (> (len ast) 2) (nth ast 2) nil)))
((= head (quote on)) (emit-on ast))
((= head (quote init))
(list
(quote hs-init)
(list (quote fn) (list) (hs-to-sx (nth ast 1)))))
((= head (quote def))
(list
(quote define)
(make-symbol (nth ast 1))
(list
(quote fn)
(map make-symbol (nth ast 2))
(hs-to-sx (nth ast 3)))))
((= head (quote behavior)) (emit-behavior ast))
((= head (quote sx-eval))
(let
((src (nth ast 1)))
(if
(string? src)
(first (sx-parse src))
(list (quote cek-eval) (hs-to-sx src)))))
((= head (quote component)) (make-symbol (nth ast 1)))
((= head (quote render))
(let
((comp-raw (nth ast 1))
(kwargs (nth ast 2))
(pos (if (> (len ast) 3) (nth ast 3) nil))
(target
(if (> (len ast) 4) (hs-to-sx (nth ast 4)) nil)))
(let
((comp (if (string? comp-raw) (make-symbol comp-raw) (hs-to-sx comp-raw))))
(define
emit-kw-pairs
(fn
(pairs)
(if
(< (len pairs) 2)
(list)
(cons
(make-keyword (first pairs))
(cons
(hs-to-sx (nth pairs 1))
(emit-kw-pairs (rest (rest pairs))))))))
(let
((render-call (cons (quote render-to-html) (cons comp (emit-kw-pairs kwargs)))))
(if
pos
(list
(quote hs-put!)
render-call
pos
(if target target (quote me)))
render-call)))))
((= head (quote not-in?))
(list
(quote not)
(list
(quote hs-contains?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1)))))
((= head (quote in?))
(list
(quote hs-contains?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote type-check))
(list
(quote hs-type-check)
(hs-to-sx (nth ast 1))
(nth ast 2)))
((= head (quote type-check-strict))
(list
(quote hs-type-check-strict)
(hs-to-sx (nth ast 1))
(nth ast 2)))
((= head (quote strict-eq))
(list
(quote hs-strict-eq)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote some))
(list
(quote some)
(list
(quote fn)
(list (make-symbol (nth ast 1)))
(hs-to-sx (nth ast 3)))
(hs-to-sx (nth ast 2))))
((= head (quote every))
(list
(quote every?)
(list
(quote fn)
(list (make-symbol (nth ast 1)))
(hs-to-sx (nth ast 3)))
(hs-to-sx (nth ast 2))))
(true ast))))))))
;; ── Convenience: source → SX ─────────────────────────────────
(define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src))))

File diff suppressed because it is too large Load Diff

View File

@@ -284,7 +284,7 @@
(true true))))) (true true)))))
(define (define
hs-type-check! hs-type-check-strict
(fn (fn
(value type-name) (value type-name)
(if (nil? value) false (hs-type-check value type-name)))) (if (nil? value) false (hs-type-check value type-name))))
@@ -295,7 +295,15 @@
(define (define
hs-falsy? hs-falsy?
(fn (v) (or (nil? v) (= v false) (and (string? v) (= v ""))))) (fn
(v)
(cond
((nil? v) true)
((= v false) true)
((and (string? v) (= v "")) true)
((and (list? v) (= (len v) 0)) true)
((= v 0) true)
(true false))))
(define (define
hs-matches? hs-matches?
@@ -311,6 +319,29 @@
(fn (fn
(collection item) (collection item)
(cond (cond
((list? collection) (some (fn (x) (= x item)) collection)) ((nil? collection) false)
((string? collection) (string-contains? collection item)) ((string? collection) (string-contains? collection (str item)))
(true false)))) ((list? collection)
(if
(= (len collection) 0)
false
(if
(= (first collection) item)
true
(hs-contains? (rest collection) item))))
(true false))))
(define
hs-empty?
(fn
(v)
(cond
((nil? v) true)
((string? v) (= (len v) 0))
((list? v) (= (len v) 0))
((dict? v) (= (len (keys v)) 0))
(true false))))
(define hs-first (fn (lst) (first lst)))
(define hs-last (fn (lst) (last lst)))

View File

@@ -0,0 +1,552 @@
;; _hyperscript tokenizer — produces token stream from hyperscript source
;;
;; Tokens: {:type T :value V :pos P}
;; Types: "keyword" "ident" "number" "string" "class" "id" "attr" "style"
;; "selector" "op" "dot" "paren-open" "paren-close" "bracket-open"
;; "bracket-close" "brace-open" "brace-close" "comma" "colon"
;; "template" "local" "eof"
;; ── Token constructor ─────────────────────────────────────────────
(define hs-make-token (fn (type value pos) {:pos pos :value value :type type}))
;; ── Character predicates ──────────────────────────────────────────
(define hs-digit? (fn (c) (and (>= c "0") (<= c "9"))))
(define
hs-letter?
(fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
(define hs-ident-start? (fn (c) (or (hs-letter? c) (= c "_") (= c "$"))))
(define
hs-ident-char?
(fn
(c)
(or (hs-letter? c) (hs-digit? c) (= c "_") (= c "$") (= c "-"))))
(define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
;; ── Keyword set ───────────────────────────────────────────────────
(define
hs-keywords
(list
"on"
"end"
"set"
"to"
"put"
"into"
"before"
"after"
"add"
"remove"
"toggle"
"if"
"else"
"otherwise"
"then"
"from"
"in"
"of"
"for"
"until"
"wait"
"send"
"trigger"
"call"
"get"
"take"
"log"
"hide"
"show"
"repeat"
"while"
"times"
"forever"
"break"
"continue"
"return"
"throw"
"catch"
"finally"
"def"
"tell"
"make"
"fetch"
"as"
"with"
"every"
"or"
"and"
"not"
"is"
"no"
"the"
"my"
"me"
"it"
"its"
"result"
"true"
"false"
"null"
"when"
"between"
"at"
"by"
"queue"
"elsewhere"
"event"
"target"
"detail"
"sender"
"index"
"increment"
"decrement"
"append"
"settle"
"transition"
"over"
"closest"
"next"
"previous"
"first"
"last"
"random"
"empty"
"exists"
"matches"
"contains"
"do"
"unless"
"you"
"your"
"new"
"init"
"start"
"go"
"js"
"less"
"than"
"greater"
"class"
"anything"
"install"
"measure"
"behavior"
"called"
"render"
"eval"
"I"
"am"
"does"
"some"
"mod"
"equal"
"equals"
"really"
"include"
"includes"
"contain"
"undefined"
"exist"
"match"))
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))
;; ── Main tokenizer ────────────────────────────────────────────────
(define
hs-tokenize
(fn
(src)
(let
((tokens (list)) (pos 0) (src-len (len src)))
(define
hs-peek
(fn
(offset)
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
(define hs-cur (fn () (hs-peek 0)))
(define hs-advance! (fn (n) (set! pos (+ pos n))))
(define
skip-ws!
(fn
()
(when
(and (< pos src-len) (hs-ws? (hs-cur)))
(hs-advance! 1)
(skip-ws!))))
(define
skip-comment!
(fn
()
(when
(and (< pos src-len) (not (= (hs-cur) "\n")))
(hs-advance! 1)
(skip-comment!))))
(define
read-ident
(fn
(start)
(when
(and (< pos src-len) (hs-ident-char? (hs-cur)))
(hs-advance! 1)
(read-ident start))
(slice src start pos)))
(define
read-number
(fn
(start)
(when
(and (< pos src-len) (hs-digit? (hs-cur)))
(hs-advance! 1)
(read-number start))
(when
(and
(< pos src-len)
(= (hs-cur) ".")
(< (+ pos 1) src-len)
(hs-digit? (hs-peek 1)))
(hs-advance! 1)
(define
read-frac
(fn
()
(when
(and (< pos src-len) (hs-digit? (hs-cur)))
(hs-advance! 1)
(read-frac))))
(read-frac))
(let
((num-end pos))
(when
(and
(< pos src-len)
(or (= (hs-cur) "m") (= (hs-cur) "s")))
(if
(and
(= (hs-cur) "m")
(< (+ pos 1) src-len)
(= (hs-peek 1) "s"))
(hs-advance! 2)
(when (= (hs-cur) "s") (hs-advance! 1))))
(slice src start pos))))
(define
read-string
(fn
(quote-char)
(let
((chars (list)))
(hs-advance! 1)
(define
loop
(fn
()
(cond
(>= pos src-len)
nil
(= (hs-cur) "\\")
(do
(hs-advance! 1)
(when
(< pos src-len)
(let
((ch (hs-cur)))
(cond
(= ch "n")
(append! chars "\n")
(= ch "t")
(append! chars "\t")
(= ch "\\")
(append! chars "\\")
(= ch quote-char)
(append! chars quote-char)
:else (do (append! chars "\\") (append! chars ch)))
(hs-advance! 1)))
(loop))
(= (hs-cur) quote-char)
(hs-advance! 1)
:else (do (append! chars (hs-cur)) (hs-advance! 1) (loop)))))
(loop)
(join "" chars))))
(define
read-template
(fn
()
(let
((chars (list)))
(hs-advance! 1)
(define
loop
(fn
()
(cond
(>= pos src-len)
nil
(= (hs-cur) "`")
(hs-advance! 1)
(and
(= (hs-cur) "$")
(< (+ pos 1) src-len)
(= (hs-peek 1) "{"))
(do
(append! chars "${")
(hs-advance! 2)
(let
((depth 1))
(define
inner
(fn
()
(when
(and (< pos src-len) (> depth 0))
(cond
(= (hs-cur) "{")
(do
(set! depth (+ depth 1))
(append! chars (hs-cur))
(hs-advance! 1)
(inner))
(= (hs-cur) "}")
(do
(set! depth (- depth 1))
(when (> depth 0) (append! chars (hs-cur)))
(hs-advance! 1)
(when (> depth 0) (inner)))
:else (do
(append! chars (hs-cur))
(hs-advance! 1)
(inner))))))
(inner))
(append! chars "}")
(loop))
:else (do (append! chars (hs-cur)) (hs-advance! 1) (loop)))))
(loop)
(join "" chars))))
(define
read-selector
(fn
()
(let
((chars (list)))
(hs-advance! 1)
(define
loop
(fn
()
(cond
(>= pos src-len)
nil
(and
(= (hs-cur) "/")
(< (+ pos 1) src-len)
(= (hs-peek 1) ">"))
(hs-advance! 2)
:else (do (append! chars (hs-cur)) (hs-advance! 1) (loop)))))
(loop)
(join "" chars))))
(define
read-class-name
(fn
(start)
(when
(and
(< pos src-len)
(or
(hs-ident-char? (hs-cur))
(= (hs-cur) ":")
(= (hs-cur) "\\")
(= (hs-cur) "[")
(= (hs-cur) "]")
(= (hs-cur) "(")
(= (hs-cur) ")")))
(when (= (hs-cur) "\\") (hs-advance! 1))
(hs-advance! 1)
(read-class-name start))
(slice src start pos)))
(define
hs-emit!
(fn
(type value start)
(append! tokens (hs-make-token type value start))))
(define
scan!
(fn
()
(skip-ws!)
(when
(< pos src-len)
(let
((ch (hs-cur)) (start pos))
(cond
(and (= ch "/") (< (+ pos 1) src-len) (= (hs-peek 1) "/"))
(do (hs-advance! 2) (skip-comment!) (scan!))
(and
(= ch "<")
(< (+ pos 1) src-len)
(not (= (hs-peek 1) "="))
(or
(hs-letter? (hs-peek 1))
(= (hs-peek 1) ".")
(= (hs-peek 1) "#")
(= (hs-peek 1) "[")
(= (hs-peek 1) "*")
(= (hs-peek 1) ":")))
(do (hs-emit! "selector" (read-selector) start) (scan!))
(and
(= ch ".")
(< (+ pos 1) src-len)
(or
(hs-letter? (hs-peek 1))
(= (hs-peek 1) "-")
(= (hs-peek 1) "_")))
(do
(hs-advance! 1)
(hs-emit! "class" (read-class-name pos) start)
(scan!))
(and
(= ch "#")
(< (+ pos 1) src-len)
(hs-ident-start? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "id" (read-ident pos) start)
(scan!))
(and
(= ch "@")
(< (+ pos 1) src-len)
(hs-ident-char? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "attr" (read-ident pos) start)
(scan!))
(and
(= ch "~")
(< (+ pos 1) src-len)
(hs-letter? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "component" (str "~" (read-ident pos)) start)
(scan!))
(and
(= ch "*")
(< (+ pos 1) src-len)
(hs-letter? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "style" (read-ident pos) start)
(scan!))
(and
(= ch ":")
(< (+ pos 1) src-len)
(hs-ident-start? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "local" (read-ident pos) start)
(scan!))
(or
(= ch "\"")
(and
(= ch "'")
(not
(and
(< (+ pos 1) src-len)
(= (hs-peek 1) "s")
(or
(>= (+ pos 2) src-len)
(not (hs-ident-char? (hs-peek 2))))))))
(do (hs-emit! "string" (read-string ch) start) (scan!))
(= ch "`")
(do (hs-emit! "template" (read-template) start) (scan!))
(hs-digit? ch)
(do (hs-emit! "number" (read-number start) start) (scan!))
(hs-ident-start? ch)
(do
(let
((word (read-ident start)))
(hs-emit!
(if (hs-keyword? word) "keyword" "ident")
word
start))
(scan!))
(and
(or (= ch "=") (= ch "!") (= ch "<") (= ch ">"))
(< (+ pos 1) src-len)
(= (hs-peek 1) "="))
(do
(if
(and
(or (= ch "=") (= ch "!"))
(< (+ pos 2) src-len)
(= (hs-peek 2) "="))
(do (hs-emit! "op" (str ch "==") start) (hs-advance! 3))
(do (hs-emit! "op" (str ch "=") start) (hs-advance! 2)))
(scan!))
(and
(= ch "'")
(< (+ pos 1) src-len)
(= (hs-peek 1) "s")
(or
(>= (+ pos 2) src-len)
(not (hs-ident-char? (hs-peek 2)))))
(do (hs-emit! "op" "'s" start) (hs-advance! 2) (scan!))
(= ch "(")
(do
(hs-emit! "paren-open" "(" start)
(hs-advance! 1)
(scan!))
(= ch ")")
(do
(hs-emit! "paren-close" ")" start)
(hs-advance! 1)
(scan!))
(= ch "[")
(do
(hs-emit! "bracket-open" "[" start)
(hs-advance! 1)
(scan!))
(= ch "]")
(do
(hs-emit! "bracket-close" "]" start)
(hs-advance! 1)
(scan!))
(= ch "{")
(do
(hs-emit! "brace-open" "{" start)
(hs-advance! 1)
(scan!))
(= ch "}")
(do
(hs-emit! "brace-close" "}" start)
(hs-advance! 1)
(scan!))
(= ch ",")
(do (hs-emit! "comma" "," start) (hs-advance! 1) (scan!))
(= ch "+")
(do (hs-emit! "op" "+" start) (hs-advance! 1) (scan!))
(= ch "-")
(do (hs-emit! "op" "-" start) (hs-advance! 1) (scan!))
(= ch "/")
(do (hs-emit! "op" "/" start) (hs-advance! 1) (scan!))
(= ch "=")
(do (hs-emit! "op" "=" start) (hs-advance! 1) (scan!))
(= ch "<")
(do (hs-emit! "op" "<" start) (hs-advance! 1) (scan!))
(= ch ">")
(do (hs-emit! "op" ">" start) (hs-advance! 1) (scan!))
(= ch "!")
(do (hs-emit! "op" "!" start) (hs-advance! 1) (scan!))
(= ch "*")
(do (hs-emit! "op" "*" start) (hs-advance! 1) (scan!))
(= ch "%")
(do (hs-emit! "op" "%" start) (hs-advance! 1) (scan!))
(= ch ".")
(do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!))
:else (do (hs-advance! 1) (scan!)))))))
(scan!)
(hs-emit! "eof" nil pos)
tokens)))