giles
64bcefffdc
Add `_hs-config-log-all` runtime flag + captured log list. When set via `hs-set-log-all!`, `hs-activate!` pushes "hyperscript:init" onto `_hs-log-captured` and mirrors to console.log. Covers cluster 30. Generator side: eval-only path now detects the logAll body pattern (`_hyperscript.config.logAll = true`) and emits a deftest that: - resets captured list - toggles log-all on - builds a div with `_="on click add .foo"` and `hs-boot-subtree!`s - asserts `(some string-contains? "hyperscript:")` over captured logs. hs-upstream-core/bootstrap: 19/26 -> 20/26. Smoke 0-195: 164 -> 165.
2305 lines
65 KiB
Plaintext
2305 lines
65 KiB
Plaintext
;; _hyperscript runtime shims
|
|
;;
|
|
;; Thin wrappers over web/lib/dom.sx and web/lib/browser.sx primitives
|
|
;; that implement hyperscript-specific semantics (async transparency,
|
|
;; class toggling, event waiting, iteration, type coercion).
|
|
;;
|
|
;; These are the functions that hs-to-sx (compiler.sx) emits calls to.
|
|
;; Each is a pure define — no platform dependency beyond the DOM/browser
|
|
;; primitives already available in the SX web platform.
|
|
|
|
;; ── Event handling ──────────────────────────────────────────────
|
|
|
|
;; 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
|
|
(define
|
|
hs-on
|
|
(fn
|
|
(target event-name handler)
|
|
(let
|
|
((wrapped (fn (event) (guard (e ((and (not (= event-name "exception")) (not (= event-name "error"))) (dom-dispatch target "exception" {:error e})) (true (raise e))) (handler event)))))
|
|
(let
|
|
((unlisten (dom-listen target event-name wrapped))
|
|
(prev (or (dom-get-data target "hs-unlisteners") (list))))
|
|
(dom-set-data target "hs-unlisteners" (append prev (list unlisten)))
|
|
unlisten))))
|
|
|
|
;; ── 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-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.
|
|
(begin
|
|
(define
|
|
hs-wait-for
|
|
(fn
|
|
(target event-name)
|
|
(perform (list (quote io-wait-event) target event-name))))
|
|
(define
|
|
hs-wait-for-or
|
|
(fn
|
|
(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-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-between!
|
|
(fn
|
|
(target cls1 cls2)
|
|
(if
|
|
(dom-has-class? target cls1)
|
|
(do (dom-remove-class target cls1) (dom-add-class target cls2))
|
|
(do (dom-remove-class target cls2) (dom-add-class target cls1)))))
|
|
|
|
;; ── Navigation / traversal ──────────────────────────────────────
|
|
|
|
;; Navigate to a URL.
|
|
(define
|
|
hs-toggle-style!
|
|
(fn
|
|
(target prop)
|
|
(let
|
|
((cur (dom-get-style target prop)))
|
|
(cond
|
|
((= prop "visibility")
|
|
(if
|
|
(= cur "hidden")
|
|
(dom-set-style target prop "visible")
|
|
(dom-set-style target prop "hidden")))
|
|
((or (= prop "display") (= prop "opacity"))
|
|
(if
|
|
(or (= cur "none") (= cur "0"))
|
|
(dom-set-style target prop (if (= prop "opacity") "1" "block"))
|
|
(dom-set-style target prop (if (= prop "display") "none" "0"))))
|
|
(true
|
|
(if
|
|
(or (= cur "") (= cur nil))
|
|
(dom-set-style target prop "hidden")
|
|
(dom-set-style target prop "")))))))
|
|
|
|
;; Find next sibling matching a selector (or any sibling).
|
|
(define
|
|
hs-toggle-style-between!
|
|
(fn
|
|
(target prop val1 val2)
|
|
(let
|
|
((cur (dom-get-style target prop)))
|
|
(if
|
|
(= cur val1)
|
|
(dom-set-style target prop val2)
|
|
(dom-set-style target prop val1)))))
|
|
|
|
;; Find previous sibling matching a selector.
|
|
(define
|
|
hs-toggle-style-cycle!
|
|
(fn
|
|
(target prop vals)
|
|
(let
|
|
((cur (dom-get-style target prop)))
|
|
(define
|
|
find-next
|
|
(fn
|
|
(remaining)
|
|
(cond
|
|
((empty? remaining) (first vals))
|
|
((= cur (first remaining))
|
|
(if
|
|
(empty? (rest remaining))
|
|
(first vals)
|
|
(first (rest remaining))))
|
|
(true (find-next (rest remaining))))))
|
|
(dom-set-style target prop (find-next vals)))))
|
|
|
|
;; First element matching selector within a scope.
|
|
(define
|
|
hs-take!
|
|
(fn
|
|
(target kind name scope &rest extra)
|
|
(let
|
|
((els (if scope (if (list? scope) scope (list scope)) (let ((parent (dom-parent target))) (if parent (dom-child-list parent) (list))))))
|
|
(if
|
|
(= kind "class")
|
|
(let
|
|
((with-cls (if (> (len extra) 1) (nth extra 1) nil)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(do
|
|
(dom-remove-class el name)
|
|
(when with-cls (dom-add-class el with-cls))))
|
|
els)
|
|
(dom-add-class target name)
|
|
(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)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(when
|
|
(not (= el target))
|
|
(if
|
|
with-val
|
|
(dom-set-attr el name with-val)
|
|
(dom-remove-attr el name))))
|
|
els)
|
|
(if
|
|
attr-val
|
|
(dom-set-attr target name attr-val)
|
|
(dom-set-attr target name ""))))))))
|
|
|
|
;; Last element matching selector.
|
|
(begin
|
|
(define
|
|
hs-element?
|
|
(fn
|
|
(v)
|
|
(and v (or (host-get v "nodeType") (host-get v "__mock_type")))))
|
|
(define
|
|
hs-set-attr!
|
|
(fn
|
|
(el name val)
|
|
(if (nil? val) (dom-remove-attr el name) (dom-set-attr el name val))))
|
|
(define
|
|
hs-toggle-attr!
|
|
(fn
|
|
(el name)
|
|
(if
|
|
(dom-has-attr? el name)
|
|
(dom-remove-attr el name)
|
|
(dom-set-attr el name ""))))
|
|
(define
|
|
hs-toggle-attr-val!
|
|
(fn
|
|
(el name val)
|
|
(if
|
|
(= (dom-get-attr el name) val)
|
|
(dom-remove-attr el name)
|
|
(dom-set-attr el name val))))
|
|
(define
|
|
hs-toggle-attr-between!
|
|
(fn
|
|
(el name val1 val2)
|
|
(if
|
|
(= (dom-get-attr el name) val1)
|
|
(dom-set-attr el name val2)
|
|
(dom-set-attr el name val1))))
|
|
(define
|
|
hs-toggle-attr-diff!
|
|
(fn
|
|
(el n1 v1 n2 v2)
|
|
(if
|
|
(dom-has-attr? el n1)
|
|
(do (dom-remove-attr el n1) (dom-set-attr el n2 v2))
|
|
(do
|
|
(when (dom-has-attr? el n2) (dom-remove-attr el n2))
|
|
(dom-set-attr el n1 v1)))))
|
|
(define
|
|
hs-set-inner-html!
|
|
(fn
|
|
(target value)
|
|
(do (dom-set-inner-html target value) (hs-boot-subtree! target))))
|
|
(define
|
|
hs-put!
|
|
(fn
|
|
(value pos target)
|
|
(cond
|
|
((= pos "into")
|
|
(cond
|
|
((list? target) target)
|
|
((hs-element? value)
|
|
(do
|
|
(dom-set-inner-html target "")
|
|
(host-call target "appendChild" value)))
|
|
(true
|
|
(do
|
|
(dom-set-inner-html target value)
|
|
(hs-boot-subtree! target)))))
|
|
((= pos "before")
|
|
(if
|
|
(hs-element? value)
|
|
(let
|
|
((parent (dom-parent target)))
|
|
(when parent (host-call parent "insertBefore" value target)))
|
|
(let
|
|
((parent (dom-parent target)))
|
|
(do
|
|
(dom-insert-adjacent-html target "beforebegin" value)
|
|
(when parent (hs-boot-subtree! parent))))))
|
|
((= pos "after")
|
|
(if
|
|
(hs-element? value)
|
|
(let
|
|
((parent (dom-parent target))
|
|
(next (host-get target "nextSibling")))
|
|
(when
|
|
parent
|
|
(if
|
|
next
|
|
(host-call parent "insertBefore" value next)
|
|
(host-call parent "appendChild" value))))
|
|
(let
|
|
((parent (dom-parent target)))
|
|
(do
|
|
(dom-insert-adjacent-html target "afterend" value)
|
|
(when parent (hs-boot-subtree! parent))))))
|
|
((= pos "start")
|
|
(cond
|
|
((list? target) (append! target value 0))
|
|
((hs-element? value) (dom-prepend target value))
|
|
(true
|
|
(do
|
|
(dom-insert-adjacent-html target "afterbegin" value)
|
|
(hs-boot-subtree! target)))))
|
|
((= pos "end")
|
|
(cond
|
|
((list? target) (append! target value))
|
|
((hs-element? value) (dom-append target value))
|
|
(true
|
|
(do
|
|
(dom-insert-adjacent-html target "beforeend" value)
|
|
(hs-boot-subtree! target)))))))))
|
|
|
|
;; First/last within a specific scope.
|
|
(define
|
|
hs-add-to!
|
|
(fn
|
|
(value target)
|
|
(cond
|
|
((list? target)
|
|
(if
|
|
(some (fn (x) (= x value)) target)
|
|
target
|
|
(append target (list value))))
|
|
(true (do (host-call target "push" value) target)))))
|
|
|
|
(define
|
|
hs-remove-from!
|
|
(fn
|
|
(value target)
|
|
(if
|
|
(list? target)
|
|
(filter (fn (x) (not (= x value))) target)
|
|
(host-call target "splice" (host-call target "indexOf" value) 1))))
|
|
|
|
;; ── Iteration ───────────────────────────────────────────────────
|
|
|
|
;; Repeat a thunk N times.
|
|
(define
|
|
hs-splice-at!
|
|
(fn
|
|
(target idx)
|
|
(if
|
|
(list? target)
|
|
(let
|
|
((n (len target)))
|
|
(let
|
|
((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))))))
|
|
(do
|
|
(when
|
|
target
|
|
(let
|
|
((n (host-get target "length")))
|
|
(let
|
|
((i (if (< idx 0) (+ (if (nil? n) 0 n) idx) idx)))
|
|
(host-call target "splice" i 1))))
|
|
target))))
|
|
|
|
;; Repeat forever (until break — relies on exception/continuation).
|
|
(define
|
|
hs-put-at!
|
|
(fn
|
|
(value pos target)
|
|
(cond
|
|
((nil? target) (list value))
|
|
((list? target)
|
|
(if
|
|
(= pos "start")
|
|
(cons value target)
|
|
(append target (list value))))
|
|
(true
|
|
(do
|
|
(cond
|
|
((= pos "end") (host-call target "push" value))
|
|
((= pos "start") (host-call target "unshift" value)))
|
|
target)))))
|
|
|
|
;; ── Fetch ───────────────────────────────────────────────────────
|
|
|
|
;; Fetch a URL, parse response according to format.
|
|
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
|
(define
|
|
hs-dict-without
|
|
(fn
|
|
(obj key)
|
|
(cond
|
|
((nil? obj) (dict))
|
|
((dict? obj)
|
|
(let
|
|
((out (dict)))
|
|
(for-each
|
|
(fn (k) (when (not (= k key)) (dict-set! out k (get obj k))))
|
|
(keys obj))
|
|
out))
|
|
(true
|
|
(let
|
|
((out (dict)))
|
|
(host-call (host-global "Object") "assign" out obj)
|
|
(host-call (host-global "Reflect") "deleteProperty" out key)
|
|
out)))))
|
|
|
|
;; ── Type coercion ───────────────────────────────────────────────
|
|
|
|
;; Coerce a value to a type by name.
|
|
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
|
(define
|
|
hs-set-on!
|
|
(fn
|
|
(props target)
|
|
(for-each (fn (k) (host-set! target k (get props k))) (keys props))))
|
|
|
|
;; ── Object creation ─────────────────────────────────────────────
|
|
|
|
;; Make a new object of a given type.
|
|
;; (hs-make type-name) — creates empty object/collection
|
|
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
|
|
|
|
;; ── 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-scroll!
|
|
(fn
|
|
(target position)
|
|
(host-call
|
|
target
|
|
"scrollIntoView"
|
|
(list
|
|
(cond
|
|
((= position "bottom") (dict :block "end"))
|
|
(true (dict :block "start")))))))
|
|
|
|
;; ── 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-halt!
|
|
(fn
|
|
(ev mode)
|
|
(do
|
|
(when
|
|
ev
|
|
(cond
|
|
((= mode "default") (host-call ev "preventDefault"))
|
|
((= mode "bubbling") (host-call ev "stopPropagation"))
|
|
((= mode "the-event")
|
|
(do
|
|
(host-call ev "preventDefault")
|
|
(host-call ev "stopPropagation")))
|
|
(true
|
|
(do
|
|
(host-call ev "preventDefault")
|
|
(host-call ev "stopPropagation")))))
|
|
(when (not (= mode "the-event")) (raise (list "hs-return" nil))))))
|
|
|
|
;; 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-select! (fn (target) (host-call target "select" (list))))
|
|
|
|
|
|
;; ── Transition ──────────────────────────────────────────────────
|
|
|
|
;; Transition a CSS property to a value, optionally with duration.
|
|
;; (hs-transition target prop value duration)
|
|
(define
|
|
hs-get-selection
|
|
(fn
|
|
()
|
|
(let
|
|
((win (host-global "window")))
|
|
(let
|
|
((stash (host-get win "__test_selection")))
|
|
(if
|
|
(nil? stash)
|
|
(let
|
|
((sel (host-call win "getSelection" (list))))
|
|
(if (nil? sel) "" (host-call sel "toString" (list))))
|
|
stash)))))
|
|
|
|
(define
|
|
hs-reset!
|
|
(fn
|
|
(target)
|
|
(cond
|
|
((list? target) (for-each (fn (el) (hs-reset! el)) target))
|
|
((nil? target) nil)
|
|
(true
|
|
(let
|
|
((tag (dom-get-prop target "tagName")))
|
|
(cond
|
|
((= tag "FORM") (host-call target "reset" (list)))
|
|
((or (= tag "INPUT") (= tag "TEXTAREA"))
|
|
(let
|
|
((input-type (dom-get-prop target "type")))
|
|
(cond
|
|
((or (= input-type "checkbox") (= input-type "radio"))
|
|
(dom-set-prop
|
|
target
|
|
"checked"
|
|
(dom-get-prop target "defaultChecked")))
|
|
(true
|
|
(dom-set-prop
|
|
target
|
|
"value"
|
|
(dom-get-prop target "defaultValue"))))))
|
|
((= tag "SELECT")
|
|
(let
|
|
((options (host-call target "querySelectorAll" "option"))
|
|
(default-val nil))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(opt)
|
|
(when
|
|
(and
|
|
(nil? default-val)
|
|
(dom-get-prop opt "defaultSelected"))
|
|
(set! default-val (dom-get-prop opt "value"))))
|
|
options)
|
|
(when
|
|
(and (nil? default-val) (> (len options) 0))
|
|
(set! default-val (dom-get-prop (first options) "value")))
|
|
(when default-val (dom-set-prop target "value" default-val)))))
|
|
(true nil)))))))
|
|
|
|
(define
|
|
hs-next
|
|
(fn
|
|
(target sel)
|
|
(if
|
|
(= sel "*")
|
|
(dom-next-sibling target)
|
|
(let
|
|
((sibling (dom-next-sibling target)))
|
|
(define
|
|
find-next
|
|
(fn
|
|
(el)
|
|
(cond
|
|
((nil? el) nil)
|
|
((dom-matches? el sel) el)
|
|
(true (find-next (dom-next-sibling el))))))
|
|
(find-next sibling)))))
|
|
|
|
(define
|
|
hs-previous
|
|
(fn
|
|
(target sel)
|
|
(if
|
|
(= sel "*")
|
|
(dom-get-prop target "previousElementSibling")
|
|
(let
|
|
((sibling (dom-get-prop target "previousElementSibling")))
|
|
(define
|
|
find-prev
|
|
(fn
|
|
(el)
|
|
(cond
|
|
((nil? el) nil)
|
|
((dom-matches? el sel) el)
|
|
(true (find-prev (dom-get-prop el "previousElementSibling"))))))
|
|
(find-prev sibling)))))
|
|
|
|
(define
|
|
hs-query-all
|
|
(fn (sel) (host-call (dom-body) "querySelectorAll" sel)))
|
|
|
|
(define
|
|
hs-query-all-in
|
|
(fn
|
|
(sel target)
|
|
(if
|
|
(nil? target)
|
|
(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))))
|
|
|
|
(define
|
|
hs-query-first
|
|
(fn (sel) (host-call (host-global "document") "querySelector" sel)))
|
|
|
|
(define
|
|
hs-query-last
|
|
(fn
|
|
(sel)
|
|
(let
|
|
((all (dom-query-all (dom-body) sel)))
|
|
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
|
|
|
|
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
|
|
|
|
|
|
|
|
|
|
|
|
(define
|
|
hs-last
|
|
(fn
|
|
(scope sel)
|
|
(let
|
|
((all (dom-query-all scope sel)))
|
|
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
|
|
|
|
(define
|
|
hs-repeat-times
|
|
(fn
|
|
(n thunk)
|
|
(define
|
|
do-repeat
|
|
(fn
|
|
(i)
|
|
(when
|
|
(< i n)
|
|
(let
|
|
((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil))))
|
|
(cond
|
|
((= signal "hs-break") nil)
|
|
((= signal "hs-continue") (do-repeat (+ i 1)))
|
|
(true (do-repeat (+ i 1))))))))
|
|
(do-repeat 0)))
|
|
;; ── Sandbox/test runtime additions ──────────────────────────────
|
|
;; Property access — dot notation and .length
|
|
(define
|
|
hs-repeat-forever
|
|
(fn
|
|
(thunk)
|
|
(define
|
|
do-forever
|
|
(fn
|
|
()
|
|
(let
|
|
((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil))))
|
|
(cond
|
|
((= signal "hs-break") nil)
|
|
((= signal "hs-continue") (do-forever))
|
|
(true (do-forever))))))
|
|
(do-forever)))
|
|
;; DOM query stub — sandbox returns empty list
|
|
(define
|
|
hs-repeat-while
|
|
(fn
|
|
(cond-fn thunk)
|
|
(when
|
|
(cond-fn)
|
|
(let
|
|
((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil))))
|
|
(cond
|
|
((= signal "hs-break") nil)
|
|
((= signal "hs-continue") (hs-repeat-while cond-fn thunk))
|
|
(true (hs-repeat-while cond-fn thunk)))))))
|
|
;; Method dispatch — obj.method(args)
|
|
(define
|
|
hs-repeat-until
|
|
(fn
|
|
(cond-fn thunk)
|
|
(let
|
|
((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil))))
|
|
(cond
|
|
((= signal "hs-break") nil)
|
|
((= signal "hs-continue")
|
|
(if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
|
|
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
|
|
|
|
;; ── 0.9.90 features ─────────────────────────────────────────────
|
|
;; beep! — debug logging, returns value unchanged
|
|
(define
|
|
hs-for-each
|
|
(fn
|
|
(fn-body collection)
|
|
(let
|
|
((items (cond ((list? collection) collection) ((dict? collection) (keys collection)) ((nil? collection) (list)) (true (list)))))
|
|
(define
|
|
do-loop
|
|
(fn
|
|
(remaining)
|
|
(when
|
|
(not (empty? remaining))
|
|
(let
|
|
((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (fn-body (first remaining)) nil))))
|
|
(cond
|
|
((= signal "hs-break") nil)
|
|
((= signal "hs-continue") (do-loop (rest remaining)))
|
|
(true (do-loop (rest remaining))))))))
|
|
(do-loop items))))
|
|
;; Property-based is — check obj.key truthiness
|
|
(begin
|
|
(define
|
|
hs-append
|
|
(fn
|
|
(target value)
|
|
(cond
|
|
((nil? target) value)
|
|
((string? target) (str target value))
|
|
((list? target)
|
|
(if
|
|
(some (fn (x) (= x value)) target)
|
|
target
|
|
(append target (list value))))
|
|
((hs-element? target)
|
|
(do
|
|
(dom-insert-adjacent-html target "beforeend" (str value))
|
|
target))
|
|
(true (str target value)))))
|
|
(define
|
|
hs-append!
|
|
(fn
|
|
(value target)
|
|
(cond
|
|
((nil? target) nil)
|
|
((hs-element? target)
|
|
(dom-insert-adjacent-html target "beforeend" (str value)))
|
|
(true nil)))))
|
|
;; Array slicing (inclusive both ends)
|
|
(define
|
|
hs-sender
|
|
(fn
|
|
(event)
|
|
(let
|
|
((detail (host-get event "detail")))
|
|
(if detail (host-get detail "sender") nil))))
|
|
;; Collection: sorted by
|
|
(define
|
|
hs-host-to-sx
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((nil? v) v)
|
|
((number? v) v)
|
|
((string? v) v)
|
|
((boolean? v) v)
|
|
(true
|
|
(let
|
|
((marker (host-get v "_type")))
|
|
(cond
|
|
((= marker "dict")
|
|
(let
|
|
((out (dict)))
|
|
(begin
|
|
(for-each
|
|
(fn (k) (dict-set! out k (hs-host-to-sx (get v k))))
|
|
(keys v))
|
|
out)))
|
|
((= marker "list") (map hs-host-to-sx v))
|
|
(true
|
|
(let
|
|
((is-array (host-call (host-global "Array") "isArray" v)))
|
|
(if
|
|
is-array
|
|
(let
|
|
((len (host-get v "length")) (out (list)))
|
|
(begin
|
|
(let
|
|
((i 0))
|
|
(for-each
|
|
(fn
|
|
(_)
|
|
(begin
|
|
(set!
|
|
out
|
|
(append
|
|
out
|
|
(list (hs-host-to-sx (host-get v i)))))
|
|
(set! i (+ i 1))))
|
|
(range 0 len)))
|
|
out))
|
|
(let
|
|
((out (dict)))
|
|
(begin
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(dict-set! out k (hs-host-to-sx (host-get v k))))
|
|
(host-call (host-global "Object") "keys" v))
|
|
out)))))))))))
|
|
;; Collection: sorted by descending
|
|
(define
|
|
hs-fetch
|
|
(fn
|
|
(url format)
|
|
(let
|
|
((fmt (cond ((nil? format) "text") ((or (= format "json") (= format "JSON") (= format "Object")) "json") ((or (= format "html") (= format "HTML")) "html") ((or (= format "response") (= format "Response")) "response") ((or (= format "text") (= format "Text")) "text") (true format))))
|
|
(let
|
|
((raw (perform (list "io-fetch" url fmt))))
|
|
(cond ((= fmt "json") (hs-host-to-sx raw)) (true raw))))))
|
|
;; Collection: split by
|
|
(define
|
|
hs-json-escape
|
|
(fn
|
|
(s)
|
|
(str
|
|
"\""
|
|
(let
|
|
((out "") (i 0) (n (string-length s)))
|
|
(define
|
|
walk
|
|
(fn
|
|
()
|
|
(when
|
|
(< i n)
|
|
(let
|
|
((c (substring s i (+ i 1))))
|
|
(set!
|
|
out
|
|
(cond
|
|
((= c "\\") (str out "\\\\"))
|
|
((= c "\"") (str out "\\\""))
|
|
((= c "\n") (str out "\\n"))
|
|
((= c "\r") (str out "\\r"))
|
|
((= c "\t") (str out "\\t"))
|
|
(true (str out c))))
|
|
(set! i (+ i 1))
|
|
(walk)))))
|
|
(walk)
|
|
out)
|
|
"\"")))
|
|
;; Collection: joined by
|
|
(define
|
|
hs-json-stringify
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((nil? v) "null")
|
|
((= v true) "true")
|
|
((= v false) "false")
|
|
((number? v) (str v))
|
|
((string? v) (hs-json-escape v))
|
|
((list? v) (str "[" (join "," (map hs-json-stringify v)) "]"))
|
|
((dict? v)
|
|
(let
|
|
((ks (or (get v "_order") (filter (fn (k) (not (= k "_order"))) (keys v)))))
|
|
(str
|
|
"{"
|
|
(join
|
|
","
|
|
(filter
|
|
(fn (s) (not (= s "")))
|
|
(map
|
|
(fn
|
|
(k)
|
|
(if
|
|
(= k "_order")
|
|
""
|
|
(str
|
|
(hs-json-escape k)
|
|
":"
|
|
(hs-json-stringify (get v k)))))
|
|
ks)))
|
|
"}")))
|
|
(true (hs-json-escape (str v))))))
|
|
|
|
(define
|
|
hs-coerce
|
|
(fn
|
|
(value type-name)
|
|
(cond
|
|
((= type-name "Int") (floor (+ value 0)))
|
|
((= type-name "Integer") (floor (+ value 0)))
|
|
((= type-name "Float") (+ value 0))
|
|
((= type-name "Number") (+ value 0))
|
|
((= type-name "String")
|
|
(if
|
|
(list? value)
|
|
(join "," (map (fn (x) (str x)) value))
|
|
(str value)))
|
|
((= type-name "Bool") (not (hs-falsy? value)))
|
|
((= type-name "Boolean") (not (hs-falsy? value)))
|
|
((= type-name "Array") (if (list? value) value (list value)))
|
|
((= type-name "HTML")
|
|
(cond
|
|
((list? value) (join "" (map (fn (x) (str x)) value)))
|
|
((hs-element? value) (host-get value "outerHTML"))
|
|
(true (str value))))
|
|
((= type-name "JSON")
|
|
(cond
|
|
((string? value) (guard (_e (true value)) (json-parse value)))
|
|
((dict? value) (hs-json-stringify value))
|
|
((list? value) (hs-json-stringify value))
|
|
(true value)))
|
|
((= type-name "Object")
|
|
(if
|
|
(string? value)
|
|
(guard (_e (true value)) (json-parse value))
|
|
value))
|
|
((= type-name "JSONString") (hs-json-stringify value))
|
|
((= type-name "FormEncoded")
|
|
(if
|
|
(dict? value)
|
|
(let
|
|
((ks (or (get value "_order") (filter (fn (k) (not (= k "_order"))) (keys value)))))
|
|
(join
|
|
"&"
|
|
(filter
|
|
(fn (s) (not (= s "")))
|
|
(map
|
|
(fn
|
|
(k)
|
|
(if
|
|
(= k "_order")
|
|
""
|
|
(let
|
|
((v (get value k)))
|
|
(if
|
|
(list? v)
|
|
(join "&" (map (fn (item) (str k "=" item)) v))
|
|
(str k "=" v)))))
|
|
ks))))
|
|
(str value)))
|
|
((or (= type-name "Fixed") (= type-name "Fixed:") (starts-with? type-name "Fixed:"))
|
|
(let
|
|
((digits (if (> (string-length type-name) 6) (+ (substring type-name 6 (string-length type-name)) 0) 0))
|
|
(num (+ value 0)))
|
|
(if
|
|
(= digits 0)
|
|
(str (floor num))
|
|
(let
|
|
((factor (pow 10 digits)))
|
|
(str (/ (floor (+ (* num factor) 0.5)) factor))))))
|
|
((= type-name "Selector") (str value))
|
|
((= type-name "Fragment") value)
|
|
((= type-name "Values") (hs-as-values value))
|
|
((= type-name "Keys") (if (dict? value) (sort (keys value)) value))
|
|
((= type-name "Entries")
|
|
(if
|
|
(dict? value)
|
|
(map (fn (k) (list k (get value k))) (keys value))
|
|
value))
|
|
((= type-name "Reversed") (if (list? value) (reverse value) value))
|
|
((= type-name "Unique")
|
|
(if
|
|
(list? value)
|
|
(reduce
|
|
(fn
|
|
(acc x)
|
|
(if (some (fn (a) (= a x)) acc) acc (append acc (list x))))
|
|
(list)
|
|
value)
|
|
value))
|
|
((or (= type-name "Flattened") (= type-name "Flat"))
|
|
(if
|
|
(list? value)
|
|
(reduce
|
|
(fn
|
|
(acc x)
|
|
(if (list? x) (append acc x) (append acc (list x))))
|
|
(list)
|
|
value)
|
|
value))
|
|
((= type-name "Set")
|
|
(if
|
|
(list? value)
|
|
(reduce
|
|
(fn
|
|
(acc x)
|
|
(if (some (fn (a) (= a x)) acc) acc (append acc (list x))))
|
|
(list)
|
|
value)
|
|
value))
|
|
((= type-name "Map")
|
|
(if
|
|
(dict? value)
|
|
(map (fn (k) (list k (get value k))) (keys value))
|
|
value))
|
|
(true value))))
|
|
|
|
(define
|
|
hs-gather-form-nodes
|
|
(fn
|
|
(root)
|
|
(let
|
|
((acc (list)))
|
|
(define
|
|
walk
|
|
(fn
|
|
(node)
|
|
(let
|
|
((tag (host-get node "tagName")))
|
|
(cond
|
|
((or (= tag "INPUT") (= tag "SELECT") (= tag "TEXTAREA"))
|
|
(set! acc (append acc (list node))))
|
|
(true
|
|
(let
|
|
((kids (host-get node "children")))
|
|
(when
|
|
(not (nil? kids))
|
|
(cond
|
|
((list? kids)
|
|
(let
|
|
((n (len kids)))
|
|
(define
|
|
each
|
|
(fn
|
|
(i)
|
|
(when
|
|
(< i n)
|
|
(walk (nth kids i))
|
|
(each (+ i 1)))))
|
|
(each 0)))
|
|
(true
|
|
(let
|
|
((n (or (host-get kids "length") 0)))
|
|
(define
|
|
each-h
|
|
(fn
|
|
(i)
|
|
(when
|
|
(< i n)
|
|
(walk (host-get kids i))
|
|
(each-h (+ i 1)))))
|
|
(each-h 0)))))))))))
|
|
(walk root)
|
|
acc)))
|
|
|
|
(define
|
|
hs-values-from-nodes
|
|
(fn (nodes) (reduce hs-values-absorb (dict) nodes)))
|
|
|
|
(define
|
|
hs-value-of-node
|
|
(fn
|
|
(node)
|
|
(let
|
|
((tag (host-get node "tagName")) (typ (host-get node "type")))
|
|
(cond
|
|
((= tag "SELECT")
|
|
(if
|
|
(host-get node "multiple")
|
|
(hs-select-multi-values node)
|
|
(host-get node "value")))
|
|
((or (= typ "checkbox") (= typ "radio"))
|
|
(if (host-get node "checked") (host-get node "value") nil))
|
|
(true (host-get node "value"))))))
|
|
|
|
(define
|
|
hs-select-multi-values
|
|
(fn
|
|
(node)
|
|
(let
|
|
((options (host-get node "options")) (acc (list)))
|
|
(if
|
|
(or (nil? options) (not (list? options)))
|
|
acc
|
|
(let
|
|
((n (len options)))
|
|
(define
|
|
each
|
|
(fn
|
|
(i)
|
|
(when
|
|
(< i n)
|
|
(let
|
|
((opt (nth options i)))
|
|
(when
|
|
(host-get opt "selected")
|
|
(set! acc (append acc (list (host-get opt "value"))))))
|
|
(each (+ i 1)))))
|
|
(each 0)
|
|
acc)))))
|
|
|
|
(define
|
|
hs-values-absorb
|
|
(fn
|
|
(acc node)
|
|
(let
|
|
((name (host-get node "name")))
|
|
(if
|
|
(or (nil? name) (= name ""))
|
|
acc
|
|
(let
|
|
((v (hs-value-of-node node)))
|
|
(cond
|
|
((nil? v) acc)
|
|
((has-key? acc name)
|
|
(let
|
|
((existing (get acc name)))
|
|
(do
|
|
(if
|
|
(list? existing)
|
|
(dict-set! acc name (append existing (list v)))
|
|
(dict-set! acc name (list existing v)))
|
|
acc)))
|
|
(true
|
|
(begin
|
|
(dict-set! acc name v)
|
|
(let
|
|
((ord (or (get acc "_order") (list))))
|
|
(when
|
|
(not (some (fn (x) (= x name)) ord))
|
|
(dict-set! acc "_order" (append ord (list name)))))
|
|
acc))))))))
|
|
|
|
(define
|
|
hs-as-values
|
|
(fn
|
|
(value)
|
|
(cond
|
|
((nil? value) (dict))
|
|
((list? value) (hs-values-from-nodes value))
|
|
(true
|
|
(let
|
|
((tag (host-get value "tagName")))
|
|
(cond
|
|
((or (= tag "INPUT") (= tag "SELECT") (= tag "TEXTAREA"))
|
|
(hs-values-from-nodes (list value)))
|
|
(true (hs-values-from-nodes (hs-gather-form-nodes value)))))))))
|
|
|
|
(define
|
|
hs-default?
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((nil? v) true)
|
|
((and (string? v) (= v "")) true)
|
|
(true false))))
|
|
|
|
(define
|
|
hs-array-set!
|
|
(fn
|
|
(arr i v)
|
|
(if (list? arr) (do (set-nth! arr i v) v) (host-set! arr i v))))
|
|
|
|
(define
|
|
hs-add
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((list? a) (if (list? b) (append a b) (append a (list b))))
|
|
((list? b) (cons a b))
|
|
((or (string? a) (string? b)) (str a b))
|
|
(true (+ a b)))))
|
|
|
|
(begin
|
|
(define
|
|
hs-make
|
|
(fn
|
|
(type-name &rest args)
|
|
(if
|
|
(hs-make-element? type-name)
|
|
(hs-make-element type-name)
|
|
(let
|
|
((ctor (host-global type-name)))
|
|
(if
|
|
(nil? ctor)
|
|
(cond
|
|
((= type-name "Object") (dict))
|
|
((= type-name "Array") (list))
|
|
((= type-name "Set") (list))
|
|
((= type-name "Map") (dict))
|
|
(true (dict)))
|
|
(apply host-new (cons type-name args)))))))
|
|
(define
|
|
hs-make-element?
|
|
(fn
|
|
(s)
|
|
(and
|
|
(string? s)
|
|
(> (len s) 0)
|
|
(let
|
|
((c (substring s 0 1)))
|
|
(or
|
|
(= c ".")
|
|
(= c "#")
|
|
(contains? s ".")
|
|
(contains? s "#")
|
|
(and (hs-lower-letter? c) (not (any-upper? s))))))))
|
|
(define hs-lower-letter? (fn (c) (and (>= c "a") (<= c "z"))))
|
|
(define
|
|
any-upper?
|
|
(fn
|
|
(s)
|
|
(let
|
|
((n (len s)))
|
|
(define
|
|
scan
|
|
(fn
|
|
(i)
|
|
(cond
|
|
((>= i n) false)
|
|
((and (>= (substring s i (+ i 1)) "A") (<= (substring s i (+ i 1)) "Z"))
|
|
true)
|
|
(true (scan (+ i 1))))))
|
|
(scan 0))))
|
|
(define
|
|
hs-make-element
|
|
(fn
|
|
(sel)
|
|
(let
|
|
((parsed (hs-parse-element-selector sel)))
|
|
(let
|
|
((tag (get parsed "tag"))
|
|
(id (get parsed "id"))
|
|
(classes (get parsed "classes")))
|
|
(let
|
|
((el (dom-create-element (if (= tag "") "div" tag))))
|
|
(when (and id (not (= id ""))) (dom-set-attr el "id" id))
|
|
(for-each (fn (c) (dom-add-class el c)) classes)
|
|
el)))))
|
|
(define
|
|
hs-parse-element-selector
|
|
(fn
|
|
(sel)
|
|
(let
|
|
((n (len sel))
|
|
(tag "")
|
|
(id "")
|
|
(classes (list))
|
|
(cur "")
|
|
(mode "tag"))
|
|
(define
|
|
flush!
|
|
(fn
|
|
()
|
|
(cond
|
|
((= mode "tag") (set! tag cur))
|
|
((= mode "id") (set! id cur))
|
|
((= mode "class") (set! classes (append classes (list cur)))))
|
|
(set! cur "")))
|
|
(define
|
|
walk
|
|
(fn
|
|
(i)
|
|
(when
|
|
(< i n)
|
|
(let
|
|
((ch (substring sel i (+ i 1))))
|
|
(cond
|
|
((= ch ".")
|
|
(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)))))))))
|
|
(walk 0)
|
|
(flush!)
|
|
{:tag tag :classes classes :id id}))))
|
|
|
|
(define hs-install (fn (behavior-fn) (behavior-fn me)))
|
|
|
|
(define
|
|
hs-measure
|
|
(fn (target) (perform (list (quote io-measure) target))))
|
|
|
|
(define
|
|
hs-transition
|
|
(fn
|
|
(target prop value duration)
|
|
(when
|
|
duration
|
|
(dom-set-style
|
|
target
|
|
"transition"
|
|
(str prop " " (/ duration 1000) "s")))
|
|
(dom-set-style target prop value)
|
|
(when duration (hs-settle target))))
|
|
|
|
(define
|
|
hs-transition-from
|
|
(fn
|
|
(target prop from-val to-val duration)
|
|
(dom-set-style target prop (str from-val))
|
|
(when
|
|
duration
|
|
(dom-set-style
|
|
target
|
|
"transition"
|
|
(str prop " " (/ duration 1000) "s")))
|
|
(dom-set-style target prop (str to-val))
|
|
(when duration (hs-settle target))))
|
|
|
|
(begin
|
|
(define
|
|
hs-type-check
|
|
(fn
|
|
(value type-name)
|
|
(if
|
|
(nil? value)
|
|
true
|
|
(cond
|
|
((= type-name "Number") (number? value))
|
|
((= type-name "String") (string? value))
|
|
((= type-name "Boolean") (or (= value true) (= value false)))
|
|
((= type-name "Array") (list? value))
|
|
((= type-name "Object") (dict? value))
|
|
((= type-name "Element") (= (host-typeof value) "element"))
|
|
((= type-name "Node")
|
|
(or
|
|
(= (host-typeof value) "element")
|
|
(= (host-typeof value) "text")))
|
|
(true (= (host-typeof value) (downcase type-name)))))))
|
|
(define
|
|
hs-type-assert
|
|
(fn
|
|
(value type-name)
|
|
(if
|
|
(hs-type-check value type-name)
|
|
value
|
|
(raise (str "Typecheck failed! expected " type-name)))))
|
|
(define
|
|
hs-type-assert-strict
|
|
(fn
|
|
(value type-name)
|
|
(if
|
|
(nil? value)
|
|
(raise (str "Typecheck failed! expected " type-name " but got nil"))
|
|
(hs-type-assert value 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))))
|
|
|
|
(define
|
|
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-scoped-set!
|
|
(fn (el name val) (dom-set-data el (str "hs-local-" name) val)))
|
|
|
|
(define
|
|
hs-scoped-get
|
|
(fn (el name) (dom-get-data el (str "hs-local-" name))))
|
|
|
|
(define
|
|
hs-precedes?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((nil? a) false)
|
|
((nil? b) false)
|
|
((and (dict? a) (dict? b))
|
|
(let
|
|
((pos (host-call a "compareDocumentPosition" b)))
|
|
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) 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))))
|
|
|
|
(define
|
|
hs-ends-with-ic?
|
|
(fn (str suffix) (ends-with? (downcase str) (downcase suffix))))
|
|
|
|
(define
|
|
hs-matches-ignore-case?
|
|
(fn
|
|
(target pattern)
|
|
(cond
|
|
((string? target)
|
|
(contains? (downcase (str target)) (downcase (str pattern))))
|
|
(true false))))
|
|
|
|
(define
|
|
hs-contains-ignore-case?
|
|
(fn
|
|
(haystack needle)
|
|
(contains? (downcase (str haystack)) (downcase (str needle)))))
|
|
|
|
(define
|
|
hs-falsy?
|
|
(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
|
|
hs-matches?
|
|
(fn
|
|
(target pattern)
|
|
(cond
|
|
((string? target)
|
|
(if (= pattern ".*") true (string-contains? target pattern)))
|
|
((= (host-typeof target) "element")
|
|
(if (string? pattern) (host-call target "matches" pattern) false))
|
|
(true false))))
|
|
|
|
(define
|
|
hs-contains?
|
|
(fn
|
|
(collection item)
|
|
(cond
|
|
((nil? collection) false)
|
|
((string? collection) (string-contains? collection (str item)))
|
|
((list? collection)
|
|
(cond
|
|
((nil? item) (list))
|
|
((list? item)
|
|
(filter (fn (x) (hs-contains? collection x)) item))
|
|
(true
|
|
(if
|
|
(= (len collection) 0)
|
|
false
|
|
(if
|
|
(= (first collection) item)
|
|
true
|
|
(hs-contains? (rest collection) item))))))
|
|
(true false))))
|
|
|
|
(define
|
|
hs-is
|
|
(fn
|
|
(obj thunk prop)
|
|
(cond
|
|
((and (dict? obj) (some (fn (k) (= k prop)) (keys obj)))
|
|
(not (hs-falsy? (get obj prop))))
|
|
(true
|
|
(let
|
|
((r (cek-try thunk)))
|
|
(if
|
|
(and (list? r) (= (first r) (quote ok)))
|
|
(= obj (nth r 1))
|
|
(= obj nil)))))))
|
|
|
|
(define
|
|
precedes?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((nil? a) false)
|
|
((nil? b) false)
|
|
((and (dict? a) (dict? b))
|
|
(let
|
|
((pos (host-call a "compareDocumentPosition" b)))
|
|
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
|
|
(true (< (str a) (str b))))))
|
|
|
|
(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-empty-like
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((list? v) (list))
|
|
((dict? v) (dict))
|
|
((string? v) "")
|
|
((nil? v) nil)
|
|
(true v))))
|
|
|
|
(define
|
|
hs-empty-target!
|
|
(fn
|
|
(target)
|
|
(cond
|
|
((list? target) (for-each (fn (el) (hs-empty-target! el)) target))
|
|
((nil? target) nil)
|
|
(true
|
|
(let
|
|
((tag (dom-get-prop target "tagName")))
|
|
(cond
|
|
((or (= tag "INPUT") (= tag "TEXTAREA"))
|
|
(let
|
|
((input-type (dom-get-prop target "type")))
|
|
(if
|
|
(or (= input-type "checkbox") (= input-type "radio"))
|
|
(dom-set-prop target "checked" false)
|
|
(dom-set-prop target "value" ""))))
|
|
((= tag "FORM")
|
|
(let
|
|
((children (host-call target "querySelectorAll" "input, textarea, select")))
|
|
(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
|
|
(el)
|
|
(let
|
|
((tag (dom-get-prop el "tagName")))
|
|
(cond
|
|
((= tag "DIALOG") (host-call el "showModal"))
|
|
(true
|
|
(do (dom-set-attr el "open" "") (dom-set-prop el "open" true)))))))
|
|
|
|
(define
|
|
hs-close!
|
|
(fn
|
|
(el)
|
|
(let
|
|
((tag (dom-get-prop el "tagName")))
|
|
(cond
|
|
((= tag "DIALOG") (host-call el "close"))
|
|
(true
|
|
(do
|
|
(host-call el "removeAttribute" "open")
|
|
(dom-set-prop el "open" false)))))))
|
|
|
|
(begin
|
|
(define _hs-hide-strategies (dict))
|
|
(define _hs-default-hide-strategy nil)
|
|
(define
|
|
hs-set-hide-strategies!
|
|
(fn
|
|
(strategies)
|
|
(for-each
|
|
(fn (k) (dict-set! _hs-hide-strategies k (get strategies k)))
|
|
(keys strategies))))
|
|
(define
|
|
hs-set-default-hide-strategy!
|
|
(fn (name) (set! _hs-default-hide-strategy name)))
|
|
(define
|
|
_hs-resolve-strategy
|
|
(fn
|
|
(strategy)
|
|
(cond
|
|
((and (= strategy "display") _hs-default-hide-strategy)
|
|
_hs-default-hide-strategy)
|
|
(true strategy))))
|
|
(define
|
|
hs-hide-one!
|
|
(fn
|
|
(el strategy)
|
|
(let
|
|
((resolved (_hs-resolve-strategy strategy)))
|
|
(let
|
|
((parts (split resolved ":")))
|
|
(let
|
|
((prop (first parts))
|
|
(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
|
|
((fn-val (get _hs-hide-strategies prop)))
|
|
(fn-val "hide" el val)))
|
|
((= (dom-get-prop el "tagName") "DIALOG")
|
|
(when (dom-has-attr? el "open") (host-call el "close")))
|
|
((= (dom-get-prop el "tagName") "DETAILS")
|
|
(dom-set-prop el "open" false))
|
|
((= prop "opacity")
|
|
(dom-set-style el "opacity" (if val val "0")))
|
|
((= prop "visibility")
|
|
(dom-set-style el "visibility" (if val val "hidden")))
|
|
((= prop "hidden") (dom-set-attr el "hidden" ""))
|
|
((= prop "class-hidden") (dom-add-class el "hidden"))
|
|
((= prop "class-invisible") (dom-add-class el "invisible"))
|
|
((= prop "class-opacity") (dom-add-class el "opacity-0"))
|
|
(true (dom-set-style el "display" (if val val "none")))))))))
|
|
(define
|
|
hs-hide!
|
|
(fn
|
|
(target strategy)
|
|
(if
|
|
(list? target)
|
|
(do (for-each (fn (el) (hs-hide-one! el strategy)) target) target)
|
|
(do (hs-hide-one! target strategy) target)))))
|
|
|
|
(begin
|
|
(define
|
|
hs-show-one!
|
|
(fn
|
|
(el strategy)
|
|
(let
|
|
((resolved (_hs-resolve-strategy strategy)))
|
|
(let
|
|
((parts (split resolved ":")))
|
|
(let
|
|
((prop (first parts))
|
|
(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
|
|
((fn-val (get _hs-hide-strategies prop)))
|
|
(fn-val "show" el val)))
|
|
((= (dom-get-prop el "tagName") "DIALOG")
|
|
(when
|
|
(not (dom-has-attr? el "open"))
|
|
(host-call el "showModal")))
|
|
((= (dom-get-prop el "tagName") "DETAILS")
|
|
(dom-set-prop el "open" true))
|
|
((= prop "opacity")
|
|
(dom-set-style el "opacity" (if val val "1")))
|
|
((= prop "visibility")
|
|
(dom-set-style el "visibility" (if val val "visible")))
|
|
((= prop "hidden") (dom-remove-attr el "hidden"))
|
|
((= prop "class-hidden") (dom-remove-class el "hidden"))
|
|
((= prop "class-invisible") (dom-remove-class el "invisible"))
|
|
((= prop "class-opacity") (dom-remove-class el "opacity-0"))
|
|
(true (dom-set-style el "display" (if val val "block")))))))))
|
|
(define
|
|
hs-show!
|
|
(fn
|
|
(target strategy)
|
|
(if
|
|
(list? target)
|
|
(do (for-each (fn (el) (hs-show-one! el strategy)) target) target)
|
|
(do (hs-show-one! target strategy) target)))))
|
|
|
|
(define
|
|
hs-show-when!
|
|
(fn
|
|
(target strategy pred)
|
|
(let
|
|
((items (if (list? target) target (list target))))
|
|
(let
|
|
((matched (list)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(if
|
|
(pred el)
|
|
(do (hs-show-one! el strategy) (append! matched el))
|
|
(hs-hide-one! el strategy)))
|
|
items)
|
|
matched)))))
|
|
|
|
(define
|
|
hs-hide-when!
|
|
(fn
|
|
(target strategy pred)
|
|
(let
|
|
((items (if (list? target) target (list target))))
|
|
(let
|
|
((matched (list)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(if
|
|
(pred el)
|
|
(do (hs-hide-one! el strategy) (append! matched el))
|
|
(hs-show-one! el strategy)))
|
|
items)
|
|
matched)))))
|
|
|
|
(define hs-first (fn (lst) (first lst)))
|
|
|
|
(define hs-last (fn (lst) (last lst)))
|
|
|
|
(define
|
|
hs-template
|
|
(fn
|
|
(raw)
|
|
(let
|
|
((result "") (i 0) (n (len raw)))
|
|
(define
|
|
tpl-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(< i n)
|
|
(let
|
|
((ch (nth raw i)))
|
|
(if
|
|
(and (= ch "$") (< (+ i 1) n))
|
|
(if
|
|
(= (nth raw (+ i 1)) "{")
|
|
(let
|
|
((start (+ i 2)))
|
|
(define
|
|
find-close
|
|
(fn
|
|
(j depth)
|
|
(if
|
|
(>= j n)
|
|
j
|
|
(if
|
|
(= (nth raw j) "}")
|
|
(if
|
|
(= depth 1)
|
|
j
|
|
(find-close (+ j 1) (- depth 1)))
|
|
(if
|
|
(= (nth raw j) "{")
|
|
(find-close (+ j 1) (+ depth 1))
|
|
(find-close (+ j 1) depth))))))
|
|
(let
|
|
((close (find-close start 1)))
|
|
(let
|
|
((expr-src (slice raw start close)))
|
|
(do
|
|
(set!
|
|
result
|
|
(str
|
|
result
|
|
(cek-eval (hs-to-sx (hs-compile expr-src)))))
|
|
(set! i (+ close 1))
|
|
(tpl-loop)))))
|
|
(let
|
|
((start (+ i 1)))
|
|
(define
|
|
read-id
|
|
(fn
|
|
(j)
|
|
(if
|
|
(and
|
|
(< j n)
|
|
(let
|
|
((c (nth raw j)))
|
|
(or
|
|
(and (>= c "a") (<= c "z"))
|
|
(and (>= c "A") (<= c "Z"))
|
|
(and (>= c "0") (<= c "9"))
|
|
(= c "_")
|
|
(= c "."))))
|
|
(read-id (+ j 1))
|
|
j)))
|
|
(let
|
|
((end (read-id start)))
|
|
(let
|
|
((ident (slice raw start end)))
|
|
(do
|
|
(set!
|
|
result
|
|
(str
|
|
result
|
|
(cek-eval (hs-to-sx (hs-compile ident)))))
|
|
(set! i end)
|
|
(tpl-loop))))))
|
|
(do
|
|
(set! result (str result ch))
|
|
(set! i (+ i 1))
|
|
(tpl-loop)))))))
|
|
(do (tpl-loop) result))))
|
|
|
|
(define
|
|
hs-make-object
|
|
(fn
|
|
(pairs)
|
|
(let
|
|
((d {}))
|
|
(do
|
|
(for-each
|
|
(fn (pair) (dict-set! d (first pair) (nth pair 1)))
|
|
pairs)
|
|
d))))
|
|
|
|
(define
|
|
hs-method-call
|
|
(fn
|
|
(obj method &rest args)
|
|
(cond
|
|
((= method "map") (map (first args) obj))
|
|
((= method "push") (do (append! obj (first args)) obj))
|
|
((= method "filter") (filter (first args) obj))
|
|
((= method "join") (join obj (first args)))
|
|
((= method "indexOf")
|
|
(let
|
|
((item (first args)))
|
|
(define
|
|
idx-loop
|
|
(fn
|
|
(lst i)
|
|
(if
|
|
(= (len lst) 0)
|
|
-1
|
|
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
|
|
(idx-loop obj 0)))
|
|
(true nil))))
|
|
|
|
(define hs-beep (fn (v) v))
|
|
|
|
(define hs-prop-is (fn (obj key) (not (hs-falsy? (host-get obj key)))))
|
|
|
|
(define
|
|
hs-slice
|
|
(fn
|
|
(col start end)
|
|
(cond
|
|
((nil? col) nil)
|
|
((not (list? col)) col)
|
|
(true
|
|
(let
|
|
((s (if (nil? start) 0 start))
|
|
(e (if (nil? end) (len col) (+ end 1))))
|
|
(slice col s e))))))
|
|
|
|
(define
|
|
hs-pick-first
|
|
(fn
|
|
(col n)
|
|
(cond
|
|
((nil? col) nil)
|
|
((not (list? col)) col)
|
|
(true
|
|
(let ((m (if (< n (len col)) n (len col)))) (slice col 0 m))))))
|
|
|
|
(define
|
|
hs-pick-last
|
|
(fn
|
|
(col n)
|
|
(cond
|
|
((nil? col) nil)
|
|
((not (list? col)) col)
|
|
(true
|
|
(let
|
|
((total (len col)))
|
|
(let
|
|
((start (if (< n total) (- total n) 0)))
|
|
(slice col start total)))))))
|
|
|
|
(define
|
|
hs-pick-random
|
|
(fn
|
|
(col n)
|
|
(cond
|
|
((nil? col) nil)
|
|
((not (list? col)) col)
|
|
((nil? n) (first col))
|
|
(true
|
|
(let ((m (if (< n (len col)) n (len col)))) (slice col 0 m))))))
|
|
|
|
(define
|
|
hs-pick-items
|
|
(fn
|
|
(col start end)
|
|
(cond
|
|
((nil? col) nil)
|
|
((not (list? col)) col)
|
|
(true (slice col start end)))))
|
|
|
|
(define
|
|
hs-pick-match
|
|
(fn
|
|
(regex haystack)
|
|
(cond
|
|
((nil? haystack) nil)
|
|
((nil? regex) nil)
|
|
(true (regex-match regex haystack)))))
|
|
|
|
(define
|
|
hs-sorted-by
|
|
(fn
|
|
(col key-fn)
|
|
(let
|
|
((pairs (map (fn (item) (list (key-fn item) item)) col)))
|
|
(map
|
|
(fn (p) (nth p 1))
|
|
(sort (fn (a b) (if (< (first a) (first b)) true false)) pairs)))))
|
|
|
|
(define
|
|
hs-sorted-by-desc
|
|
(fn
|
|
(col key-fn)
|
|
(let
|
|
((pairs (map (fn (item) (list (key-fn item) item)) col)))
|
|
(map
|
|
(fn (p) (nth p 1))
|
|
(sort (fn (a b) (if (> (first a) (first b)) true false)) pairs)))))
|
|
|
|
(define hs-split-by (fn (s sep) (if (nil? s) nil (split s sep))))
|
|
|
|
(define
|
|
hs-joined-by
|
|
(fn
|
|
(col sep)
|
|
(cond
|
|
((nil? col) nil)
|
|
((list? col)
|
|
(join sep (map (fn (x) (if (nil? x) "" (str x))) col)))
|
|
(true col))))
|
|
|
|
(define
|
|
hs-sorted-by
|
|
(fn
|
|
(coll key-fn)
|
|
(if
|
|
(not (list? coll))
|
|
coll
|
|
(sort
|
|
(fn
|
|
(a b)
|
|
(let
|
|
((ka (key-fn a)) (kb (key-fn b)))
|
|
(cond
|
|
((nil? ka) (not (nil? kb)))
|
|
((nil? kb) false)
|
|
(true (< ka kb)))))
|
|
coll))))
|
|
|
|
(define
|
|
hs-sorted-by
|
|
(fn
|
|
(col key-fn)
|
|
(let
|
|
((decorated (map (fn (item) (list (key-fn item) item)) col)))
|
|
(let
|
|
((sorted-dec (sort (map first decorated))))
|
|
(define
|
|
reorder
|
|
(fn
|
|
(keys acc remaining)
|
|
(if
|
|
(= (len keys) 0)
|
|
acc
|
|
(let
|
|
((k (first keys)))
|
|
(define
|
|
find-item
|
|
(fn
|
|
(lst)
|
|
(if
|
|
(= (len lst) 0)
|
|
nil
|
|
(if
|
|
(= (first (first lst)) k)
|
|
(first lst)
|
|
(find-item (rest lst))))))
|
|
(let
|
|
((found (find-item remaining)))
|
|
(reorder
|
|
(rest keys)
|
|
(append acc (list (nth found 1)))
|
|
(filter (fn (x) (not (= x found))) remaining)))))))
|
|
(reorder sorted-dec (list) decorated)))))
|
|
|
|
(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 (host-call store "hasOwnProperty" 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)
|
|
(let
|
|
((changed (not (and (hs-dom-has-var? el name) (= (hs-dom-get-var-raw el name) val)))))
|
|
(do
|
|
(when
|
|
(nil? (host-get el "__hs_vars"))
|
|
(host-set! el "__hs_vars" (host-new "Object")))
|
|
(host-set! (host-get el "__hs_vars") name val)
|
|
(when changed (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))))))
|