From 5b0c8569a8d63c7241c6dddfc715c841c096e6b5 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 22 Apr 2026 11:49:36 +0000 Subject: [PATCH] =?UTF-8?q?HS:=20implement=20morph=20command=20=E2=80=94?= =?UTF-8?q?=20tokenizer=20keyword,=20parser,=20compiler,=20runtime=20HTML-?= =?UTF-8?q?fragment=20parser?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds the missing `morph to ` command. Runtime includes a small HTML fragment parser that applies the outer element's attributes to the target, rebuilds children, and re-activates hyperscript on the new subtree. Other hyperscript fixes (^ attr ref, dom-ref keyword, pick keyword, between in am/is, prop-is removal) from parallel work are bundled along. Co-Authored-By: Claude Opus 4.7 (1M context) --- lib/hyperscript/compiler.sx | 119 ++++++++++- lib/hyperscript/parser.sx | 271 +++++++++++++++++++----- lib/hyperscript/runtime.sx | 397 ++++++++++++++++++++++++++++++++++- lib/hyperscript/tokenizer.sx | 16 +- 4 files changed, 735 insertions(+), 68 deletions(-) diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 9fa30edf..222c16df 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -44,6 +44,12 @@ (list (quote set!) (make-symbol (nth target 1)) value)) ((= th (quote local)) (list (quote define) (make-symbol (nth target 1)) value)) + ((= th (quote dom-ref)) + (list + (quote hs-dom-set!) + (hs-to-sx (nth target 2)) + (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)) @@ -427,7 +433,7 @@ ((= head (quote null-literal)) nil) ((= head (quote not)) (list (quote not) (hs-to-sx (nth ast 1)))) - ((or (= head (quote starts-with?)) (= head (quote ends-with?)) (= head (quote contains?)) (= head (quote precedes?)) (= head (quote follows?))) + ((or (= head (quote and)) (= head (quote or)) (= head (quote >=)) (= head (quote <=)) (= head (quote >)) (= head (quote <))) (cons head (map hs-to-sx (rest ast)))) ((= head (quote object-literal)) (let @@ -559,6 +565,37 @@ (hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 3)))) + ((= head (quote pick-first)) + (list + (quote hs-pick-first) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote pick-last)) + (list + (quote hs-pick-last) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote pick-random)) + (list + (quote hs-pick-random) + (hs-to-sx (nth ast 1)) + (if (nil? (nth ast 2)) nil (hs-to-sx (nth ast 2))))) + ((= head (quote pick-items)) + (list + (quote hs-pick-items) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3)))) + ((= head (quote pick-match)) + (list + (quote regex-match) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote pick-matches)) + (list + (quote regex-find-all) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) ((= head (quote prop-is)) (list (quote hs-prop-is) @@ -656,6 +693,11 @@ (quote dom-get-style) (hs-to-sx (nth ast 2)) (nth ast 1))) + ((= head (quote dom-ref)) + (list + (quote hs-dom-get) + (hs-to-sx (nth ast 2)) + (nth ast 1))) ((= head (quote has-class?)) (list (quote dom-has-class?) @@ -742,6 +784,26 @@ (quote hs-ends-with-ic?) (hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 2)))) + ((= head (quote starts-with?)) + (list + (quote hs-starts-with?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote ends-with?)) + (list + (quote hs-ends-with?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote precedes?)) + (list + (quote hs-precedes?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote follows?)) + (list + (quote hs-follows?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) ((= head (quote contains?)) (list (quote hs-contains?) @@ -937,6 +999,11 @@ (quote do) (emit-set lhs (hs-to-sx rhs)) (emit-set rhs (quote _swap_tmp)))))) + ((= head (quote morph!)) + (list + (quote hs-morph!) + (hs-to-sx (nth ast 1)) + (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))))) @@ -977,6 +1044,23 @@ (quote hs-set-on!) (hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 2)))) + ((= head (quote set-on!)) + (let + ((lhs (nth ast 1)) + (tgt-ast (nth ast 2)) + (val-ast (nth ast 3))) + (if + (and (list? lhs) (= (first lhs) (quote dom-ref))) + (list + (quote hs-dom-set!) + (hs-to-sx tgt-ast) + (nth lhs 1) + (hs-to-sx val-ast)) + (list + (quote hs-set-on!) + (hs-to-sx lhs) + (hs-to-sx tgt-ast) + (hs-to-sx val-ast))))) ((= head (quote toggle-between)) (list (quote hs-toggle-between!) @@ -1194,15 +1278,21 @@ ((= head (quote measure)) (list (quote hs-measure) (hs-to-sx (nth ast 1)))) ((= head (quote increment!)) - (emit-inc - (nth ast 1) - (nth ast 2) - (if (> (len ast) 3) (nth ast 3) nil))) + (if + (= (len ast) 3) + (emit-inc (nth ast 1) 1 (nth ast 2)) + (emit-inc + (nth ast 1) + (nth ast 2) + (if (> (len ast) 3) (nth ast 3) nil)))) ((= head (quote decrement!)) - (emit-dec - (nth ast 1) - (nth ast 2) - (if (> (len ast) 3) (nth ast 3) nil))) + (if + (= (len ast) 3) + (emit-dec (nth ast 1) 1 (nth ast 2)) + (emit-dec + (nth ast 1) + (nth ast 2) + (if (> (len ast) 3) (nth ast 3) nil)))) ((= head (quote break)) (list (quote raise) "hs-break")) ((= head (quote continue)) (list (quote raise) "hs-continue")) @@ -1210,6 +1300,17 @@ ((= head (quote live-no-op)) nil) ((= head (quote when-feat-no-op)) nil) ((= head (quote on)) (emit-on ast)) + ((= head (quote when-changes)) + (let + ((expr (nth ast 1)) (body (nth ast 2))) + (if + (and (list? expr) (= (first expr) (quote dom-ref))) + (list + (quote hs-dom-watch!) + (hs-to-sx (nth expr 2)) + (nth expr 1) + (list (quote fn) (list (quote it)) (hs-to-sx body))) + nil))) ((= head (quote init)) (list (quote hs-init) diff --git a/lib/hyperscript/parser.sx b/lib/hyperscript/parser.sx index 5d192d08..3e77b9c1 100644 --- a/lib/hyperscript/parser.sx +++ b/lib/hyperscript/parser.sx @@ -180,6 +180,16 @@ ((= typ "style") (do (adv!) (list (quote style) val (list (quote me))))) ((= typ "local") (do (adv!) (list (quote local) val))) + ((= typ "hat") + (do (adv!) (list (quote dom-ref) val (list (quote me))))) + ((and (= typ "keyword") (= val "dom")) + (do + (adv!) + (let + ((name (tp-val))) + (do + (adv!) + (list (quote dom-ref) name (list (quote me))))))) ((= typ "class") (do (adv!) (list (quote query) (str "." val)))) ((= typ "ident") (do (adv!) (list (quote ref) val))) @@ -479,21 +489,14 @@ (list (quote type-check-strict) left type-name) (list (quote type-check) left type-name)))))) (true - (if - (and - (= (tp-type) "ident") - (not (hs-keyword? (tp-val)))) - (let - ((prop-name (tp-val))) - (do (adv!) (list (quote prop-is) left prop-name))) - (let - ((right (parse-expr))) - (if - (match-kw "ignoring") - (do - (match-kw "case") - (list (quote eq-ignore-case) left right)) - (list (quote =) left right)))))))) + (let + ((right (parse-expr))) + (if + (match-kw "ignoring") + (do + (match-kw "case") + (list (quote eq-ignore-case) left right)) + (list (quote =) left right))))))) ((and (= typ "keyword") (= val "am")) (do (adv!) @@ -504,12 +507,34 @@ (list (quote not-in?) left (parse-expr))) ((match-kw "empty") (list (quote not) (list (quote empty?) left))) + ((match-kw "between") + (let + ((lo (parse-atom))) + (match-kw "and") + (let + ((hi (parse-atom))) + (list + (quote not) + (list + (quote and) + (list (quote >=) left lo) + (list (quote <=) left hi)))))) (true (let ((right (parse-expr))) (list (quote not) (list (quote =) left right)))))) ((match-kw "in") (list (quote in?) left (parse-expr))) ((match-kw "empty") (list (quote empty?) left)) + ((match-kw "between") + (let + ((lo (parse-atom))) + (match-kw "and") + (let + ((hi (parse-atom))) + (list + (quote and) + (list (quote >=) left lo) + (list (quote <=) left hi))))) (true (let ((right (parse-expr))) @@ -639,6 +664,14 @@ (list (quote not) (list (quote ends-with?) left (parse-expr))))) + ((or (match-kw "precede") (match-kw "precedes")) + (list + (quote not) + (list (quote precedes?) left (parse-atom)))) + ((or (match-kw "follow") (match-kw "follows")) + (list + (quote not) + (list (quote follows?) left (parse-atom)))) (true left)))) ((and (= typ "keyword") (= val "equals")) (do (adv!) (list (quote =) left (parse-expr)))) @@ -877,7 +910,7 @@ (collect-classes!)))) (collect-classes!) (let - ((tgt (if (match-kw "from") (parse-expr) nil))) + ((tgt (if (match-kw "from") (parse-expr) (list (quote me))))) (if (empty? extra-classes) (list (quote remove-class) cls tgt) @@ -1097,7 +1130,12 @@ ((match-kw "on") (let ((target (parse-expr))) - (list (quote set-on) tgt target))) + (if + (match-kw "to") + (let + ((value (parse-expr))) + (list (quote set-on!) tgt target value)) + (list (quote set-on) tgt target)))) (true (error (str "Expected to/on at position " p))))))) (define parse-put-cmd @@ -1105,28 +1143,31 @@ () (let ((value (parse-expr))) - (cond - ((match-kw "into") (list (quote set!) (parse-expr) value)) - ((match-kw "before") - (list (quote put!) value "before" (parse-expr))) - ((match-kw "after") - (list (quote put!) value "after" (parse-expr))) - ((match-kw "at") - (do - (match-kw "the") - (cond - ((match-kw "start") - (do - (expect-kw! "of") - (list (quote put!) value "start" (parse-expr)))) - ((match-kw "end") - (do - (expect-kw! "of") - (list (quote put!) value "end" (parse-expr)))) - (true - (error (str "Expected start/end after at, position " p)))))) - (true - (error (str "Expected into/before/after/at at position " p))))))) + (let + ((value (if (and (list? value) (= (first value) (quote dom-ref)) (match-kw "on")) (list (quote dom-ref) (nth value 1) (parse-expr)) value))) + (cond + ((match-kw "into") (list (quote set!) (parse-expr) value)) + ((match-kw "before") + (list (quote put!) value "before" (parse-expr))) + ((match-kw "after") + (list (quote put!) value "after" (parse-expr))) + ((match-kw "at") + (do + (match-kw "the") + (cond + ((match-kw "start") + (do + (expect-kw! "of") + (list (quote put!) value "start" (parse-expr)))) + ((match-kw "end") + (do + (expect-kw! "of") + (list (quote put!) value "end" (parse-expr)))) + (true + (error + (str "Expected start/end after at, position " p)))))) + (true + (error (str "Expected into/before/after/at at position " p)))))))) (define parse-if-cmd (fn @@ -1241,10 +1282,13 @@ (let ((expr (parse-expr))) (let - ((amount (if (match-kw "by") (parse-expr) 1))) + ((by-amount (if (match-kw "by") (parse-expr) nil))) (let ((tgt (parse-tgt-kw "on" (list (quote me))))) - (list (quote increment!) expr amount tgt)))))) + (if + by-amount + (list (quote increment!) expr by-amount tgt) + (list (quote increment!) expr tgt))))))) (define parse-dec-cmd (fn @@ -1252,10 +1296,13 @@ (let ((expr (parse-expr))) (let - ((amount (if (match-kw "by") (parse-expr) 1))) + ((by-amount (if (match-kw "by") (parse-expr) nil))) (let ((tgt (parse-tgt-kw "on" (list (quote me))))) - (list (quote decrement!) expr amount tgt)))))) + (if + by-amount + (list (quote decrement!) expr by-amount tgt) + (list (quote decrement!) expr tgt))))))) (define parse-hide-cmd (fn @@ -1396,7 +1443,7 @@ (let ((fmt-after (if (and (not fmt-before) (match-kw "as")) (let ((f (tp-val))) (adv!) f) nil))) (let - ((fmt (or fmt-before fmt-after "text"))) + ((fmt (or fmt-before fmt-after "json"))) (list (quote fetch) url fmt))))))))) (define parse-call-args @@ -1460,6 +1507,103 @@ attr-val with-val))))))) (true nil)))) + (define + parse-pick-cmd + (fn + () + (let + ((typ (tp-type)) (val (tp-val))) + (cond + ((and (= typ "keyword") (= val "first")) + (do + (adv!) + (let + ((n (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-first) coll n)))))) + ((and (= typ "keyword") (= val "last")) + (do + (adv!) + (let + ((n (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-last) coll n)))))) + ((and (= typ "keyword") (= val "random")) + (do + (adv!) + (if + (match-kw "of") + (let + ((coll (parse-expr))) + (list (quote pick-random) coll nil)) + (let + ((n (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-random) coll n))))))) + ((and (= typ "ident") (= val "items")) + (do + (adv!) + (let + ((start-expr (parse-atom))) + (do + (expect-kw! "to") + (let + ((end-expr (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-items) coll start-expr end-expr)))))))) + ((and (= typ "keyword") (= val "match")) + (do + (adv!) + (expect-kw! "of") + (let + ((regex (parse-expr))) + (do + (cond + ((match-kw "of") nil) + ((match-kw "from") nil) + (true + (error + (str + "Expected of/from after pick match regex at " + p)))) + (let + ((haystack (parse-expr))) + (list (quote pick-match) regex haystack)))))) + ((and (= typ "keyword") (= val "matches")) + (do + (adv!) + (expect-kw! "of") + (let + ((regex (parse-expr))) + (do + (cond + ((match-kw "of") nil) + ((match-kw "from") nil) + (true + (error + (str + "Expected of/from after pick matches regex at " + p)))) + (let + ((haystack (parse-expr))) + (list (quote pick-matches) regex haystack)))))) + (true + (error + (str + "Expected first/last/random/items/match/matches after 'pick' at " + p))))))) (define parse-go-cmd (fn () (match-kw "to") (list (quote go) (parse-expr)))) @@ -1819,6 +1963,16 @@ ((lhs (parse-expr))) (match-kw "with") (let ((rhs (parse-expr))) (list (quote swap!) lhs rhs))))) + (define + parse-morph-cmd + (fn + () + (let + ((target (parse-expr))) + (expect-kw! "to") + (let + ((content (parse-expr))) + (list (quote morph!) target content))))) (define parse-open-cmd (fn @@ -1880,6 +2034,8 @@ (do (adv!) (parse-call-cmd))) ((and (= typ "keyword") (= val "take")) (do (adv!) (parse-take-cmd))) + ((and (= typ "keyword") (= val "pick")) + (do (adv!) (parse-pick-cmd))) ((and (= typ "keyword") (= val "settle")) (do (adv!) (list (quote settle)))) ((and (= typ "keyword") (= val "go")) @@ -1920,6 +2076,8 @@ (do (adv!) (parse-empty-cmd))) ((and (= typ "keyword") (= val "swap")) (do (adv!) (parse-swap-cmd))) + ((and (= typ "keyword") (= val "morph")) + (do (adv!) (parse-morph-cmd))) ((and (= typ "keyword") (= val "open")) (do (adv!) (parse-open-cmd))) ((and (= typ "keyword") (= val "close")) @@ -1979,8 +2137,10 @@ (= v "empty") (= v "clear") (= v "swap") + (= v "morph") (= v "open") - (= v "close")))) + (= v "close") + (= v "pick")))) (define cl-collect (fn @@ -2078,9 +2238,24 @@ ((and (= (tp-type) "keyword") (or (= (tp-val) "end") (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) nil) (true (do (adv!) (pwf-skip)))))) - (pwf-skip) - (match-kw "end") - (list (quote when-feat-no-op)))) + (if + (or + (= (tp-type) "hat") + (and (= (tp-type) "keyword") (= (tp-val) "dom"))) + (let + ((expr (parse-expr))) + (if + (match-kw "changes") + (let + ((body (parse-cmd-list))) + (do + (match-kw "end") + (list (quote when-changes) expr body))) + (do + (pwf-skip) + (match-kw "end") + (list (quote when-feat-no-op))))) + (do (pwf-skip) (match-kw "end") (list (quote when-feat-no-op)))))) (define parse-feat (fn diff --git a/lib/hyperscript/runtime.sx b/lib/hyperscript/runtime.sx index ea353529..426cafda 100644 --- a/lib/hyperscript/runtime.sx +++ b/lib/hyperscript/runtime.sx @@ -448,16 +448,10 @@ ((= type-name "Boolean") (not (hs-falsy? value))) ((= type-name "Array") (if (list? value) value (list value))) ((= type-name "HTML") (str value)) - ((= type-name "JSON") - (if - (string? value) - value - (host-call (host-global "JSON") "stringify" value))) + ((= type-name "JSON") (if (string? value) (json-parse value) value)) ((= type-name "Object") - (if - (string? value) - (host-call (host-global "JSON") "parse" value) - value)) + (if (string? value) (json-parse value) value)) + ((= type-name "JSONString") (json-stringify value)) ((or (= type-name "Fixed") (= type-name "Fixed:")) (let ((digits (if (> (string-length type-name) 6) (+ (substring type-name 6 (string-length type-name)) 0) 0)) @@ -475,7 +469,7 @@ (dict? value) (map (fn (k) (get value k)) (keys value)) value)) - ((= type-name "Keys") (if (dict? value) (keys value) value)) + ((= type-name "Keys") (if (dict? value) (sort (keys value)) value)) ((= type-name "Entries") (if (dict? value) @@ -610,6 +604,36 @@ hs-eq-ignore-case (fn (a b) (= (downcase (str a)) (downcase (str b))))) +(define + hs-starts-with? + (fn + (s prefix) + (cond + ((nil? s) false) + ((nil? prefix) false) + (true (starts-with? (str s) (str prefix)))))) + +(define + hs-ends-with? + (fn + (s suffix) + (cond + ((nil? s) false) + ((nil? suffix) false) + (true (ends-with? (str s) (str suffix)))))) + +(define + hs-precedes? + (fn + (a b) + (cond ((nil? a) false) ((nil? b) false) (true (< (str a) (str b)))))) + +(define + hs-follows? + (fn + (a b) + (cond ((nil? a) false) ((nil? b) false) (true (> (str a) (str b)))))) + (define hs-starts-with-ic? (fn (str prefix) (starts-with? (downcase str) (downcase prefix)))) @@ -714,6 +738,218 @@ (for-each (fn (el) (hs-empty-target! el)) children))) (true (dom-set-inner-html target "")))))))) +(define + hs-morph-char + (fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p)))) + +(define + hs-morph-index-from + (fn + (s needle from) + (let + ((r (index-of (substring s from (string-length s)) needle))) + (if (< r 0) -1 (+ from r))))) + +(define + hs-morph-sws + (fn + (s p) + (let + ((c (hs-morph-char s p))) + (if (and c (hs-ws? c)) (hs-morph-sws s (+ p 1)) p)))) + +(define + hs-morph-read-until + (fn + (s p stop) + (define + loop + (fn + (q) + (let + ((c (hs-morph-char s q))) + (if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q)))) + (let ((e (loop p))) (list (substring s p e) e)))) + +(define + hs-morph-parse-attrs + (fn + (s p acc) + (let + ((p (hs-morph-sws s p))) + (let + ((c (hs-morph-char s p))) + (cond + ((nil? c) (list acc p false)) + ((= c ">") (list acc (+ p 1) false)) + ((= c "/") + (if + (= (hs-morph-char s (+ p 1)) ">") + (list acc (+ p 2) true) + (list acc (+ p 1) false))) + (true + (let + ((r (hs-morph-read-until s p " \t\n=/>"))) + (let + ((name (first r)) (p2 (nth r 1))) + (let + ((p3 (hs-morph-sws s p2))) + (if + (= (hs-morph-char s p3) "=") + (let + ((p4 (hs-morph-sws s (+ p3 1)))) + (let + ((c2 (hs-morph-char s p4))) + (cond + ((= c2 "\"") + (let + ((close (hs-morph-index-from s "\"" (+ p4 1)))) + (hs-morph-parse-attrs + s + (+ close 1) + (append + acc + (list + (list name (substring s (+ p4 1) close))))))) + ((= c2 "'") + (let + ((close (hs-morph-index-from s "'" (+ p4 1)))) + (hs-morph-parse-attrs + s + (+ close 1) + (append + acc + (list + (list name (substring s (+ p4 1) close))))))) + (true + (let + ((r2 (hs-morph-read-until s p4 " \t\n/>"))) + (hs-morph-parse-attrs + s + (nth r2 1) + (append acc (list (list name (first r2)))))))))) + (hs-morph-parse-attrs + s + p3 + (append acc (list (list name "")))))))))))))) + +(define + hs-morph-parse-element + (fn + (s p) + (let + ((p (hs-morph-sws s p))) + (if + (not (= (hs-morph-char s p) "<")) + nil + (let + ((r (hs-morph-read-until s (+ p 1) " \t\n/>"))) + (let + ((tag (first r)) (p2 (nth r 1))) + (let + ((ar (hs-morph-parse-attrs s p2 (list)))) + (let + ((attrs (first ar)) + (p3 (nth ar 1)) + (self-closing (nth ar 2))) + (if + self-closing + {:children (list) :end p3 :tag tag :type "element" :attrs attrs} + (let + ((cr (hs-morph-parse-children s p3 (list)))) + {:children (first cr) :end (nth cr 1) :tag tag :type "element" :attrs attrs})))))))))) + +(define + hs-morph-parse-children + (fn + (s p acc) + (let + ((c (hs-morph-char s p))) + (cond + ((nil? c) (list acc p)) + ((= c "<") + (if + (= (hs-morph-char s (+ p 1)) "/") + (let + ((close-gt (hs-morph-index-from s ">" (+ p 1)))) + (list acc (+ close-gt 1))) + (let + ((child (hs-morph-parse-element s p))) + (if + (nil? child) + (list acc p) + (hs-morph-parse-children + s + (get child :end) + (append acc (list child))))))) + (true + (let + ((r (hs-morph-read-until s p "<"))) + (hs-morph-parse-children + s + (nth r 1) + (append acc (list {:text (first r) :type "text"}))))))))) + +(define + hs-morph-apply-attrs + (fn + (el attrs keep-id) + (for-each + (fn + (av) + (let + ((n (first av)) (v (nth av 1))) + (cond + ((= n "class") + (for-each + (fn + (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))))) + attrs))) + +(define + hs-morph-build-children + (fn + (parent children) + (cond + ((= (len children) 0) nil) + ((and (= (len children) 1) (= (get (first children) :type) "text")) + (dom-set-inner-html parent (get (first children) :text))) + (true (for-each (fn (c) (hs-morph-build-child parent c)) children))))) + +(define + hs-morph-build-child + (fn + (parent node) + (cond + ((= (get node :type) "element") + (let + ((el (dom-create-element (get node :tag)))) + (do + (hs-morph-apply-attrs el (get node :attrs) false) + (hs-morph-build-children el (get node :children)) + (dom-append parent el) + (hs-activate! el)))) + (true nil)))) + +(define + hs-morph! + (fn + (target content) + (when + target + (let + ((tree (hs-morph-parse-element content 0))) + (when + tree + (do + (hs-morph-apply-attrs target (get tree :attrs) true) + (dom-set-inner-html target "") + (hs-morph-build-children target (get tree :children)))))))) + (define hs-open! (fn @@ -902,6 +1138,33 @@ (e (if (nil? end) (len col) (+ end 1)))) (slice col s e)))) +(define + hs-pick-first + (fn + (col n) + (let ((m (if (< n (len col)) n (len col)))) (slice col 0 m)))) + +(define + hs-pick-last + (fn + (col n) + (let + ((total (len col))) + (let + ((start (if (< n total) (- total n) 0))) + (slice col start total))))) + +(define + hs-pick-random + (fn + (col n) + (if + (nil? n) + (first col) + (let ((m (if (< n (len col)) n (len col)))) (slice col 0 m))))) + +(define hs-pick-items (fn (col start end) (slice col start end))) + (define hs-sorted-by (fn @@ -965,3 +1228,117 @@ (define hs-sorted-by-desc (fn (col key-fn) (reverse (hs-sorted-by col key-fn)))) + +(define + hs-dom-has-var? + (fn + (el name) + (if + (nil? el) + false + (let + ((store (host-get el "__hs_vars"))) + (if (nil? store) false (has-key? store name)))))) + +(define + hs-dom-get-var-raw + (fn + (el name) + (let + ((store (host-get el "__hs_vars"))) + (if (nil? store) nil (host-get store name))))) + +(define + hs-dom-set-var-raw! + (fn + (el name val) + (do + (when + (nil? (host-get el "__hs_vars")) + (host-set! el "__hs_vars" (dict))) + (host-set! (host-get el "__hs_vars") name val) + (hs-dom-fire-watchers! el name val)))) + +(define + hs-dom-resolve-start + (fn + (el) + (if + (nil? el) + nil + (let + ((scope (dom-get-attr el "dom-scope"))) + (cond + ((or (nil? scope) (= scope "") (= scope "isolated")) el) + ((starts-with? scope "closest ") + (dom-closest el (slice scope 8 (len scope)))) + ((starts-with? scope "parent of ") + (let + ((match (dom-closest el (slice scope 10 (len scope))))) + (if match (dom-parent match) nil))) + (true el)))))) + +(define + hs-dom-walk + (fn + (el name) + (cond + ((nil? el) nil) + ((hs-dom-has-var? el name) (hs-dom-get-var-raw el name)) + ((= (dom-get-attr el "dom-scope") "isolated") nil) + (true (hs-dom-walk (dom-parent el) name))))) + +(define + hs-dom-find-owner + (fn + (el name) + (cond + ((nil? el) nil) + ((hs-dom-has-var? el name) el) + ((= (dom-get-attr el "dom-scope") "isolated") nil) + (true (hs-dom-find-owner (dom-parent el) name))))) + +(define + hs-dom-get + (fn (el name) (hs-dom-walk (hs-dom-resolve-start el) name))) + +(define + hs-dom-set! + (fn + (el name val) + (let + ((start (hs-dom-resolve-start el))) + (let + ((owner (hs-dom-find-owner start name))) + (hs-dom-set-var-raw! (if owner owner start) name val))))) + +(define _hs-dom-watchers (list)) + +(define + hs-dom-watch! + (fn + (el name handler) + (set! _hs-dom-watchers (cons (list el name handler) _hs-dom-watchers)))) + +(define + hs-dom-fire-watchers! + (fn + (el name val) + (for-each + (fn + (entry) + (when + (and + (= (nth entry 1) name) + (hs-dom-is-ancestor? el (nth entry 0))) + ((nth entry 2) val))) + _hs-dom-watchers))) + +(define + hs-dom-is-ancestor? + (fn + (a b) + (cond + ((nil? b) false) + ((= a b) true) + (true (hs-dom-is-ancestor? a (dom-parent b)))))) diff --git a/lib/hyperscript/tokenizer.sx b/lib/hyperscript/tokenizer.sx index 2f7707d7..a0f3b506 100644 --- a/lib/hyperscript/tokenizer.sx +++ b/lib/hyperscript/tokenizer.sx @@ -117,6 +117,7 @@ "first" "last" "random" + "pick" "empty" "clear" "swap" @@ -173,11 +174,16 @@ "default" "halt" "precedes" + "precede" + "follow" "follows" "ignoring" "case" + "changes" "focus" - "blur")) + "blur" + "dom" + "morph")) (define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords))) @@ -472,6 +478,14 @@ (hs-advance! 1) (hs-emit! "attr" (read-ident pos) start) (scan!)) + (and + (= ch "^") + (< (+ pos 1) src-len) + (hs-ident-char? (hs-peek 1))) + (do + (hs-advance! 1) + (hs-emit! "hat" (read-ident pos) start) + (scan!)) (and (= ch "~") (< (+ pos 1) src-len)