giles
abbb1fe5c6
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 48s
Three-part fix for hs-upstream-core/asyncError test 2/2:
1. runtime.sx hs-win-call: when an async call returns a rejected promise,
store the error value in window.__hs_async_error (side-channel) and
raise the sentinel "__hs_async_error__" so the value survives the
raise boundary intact.
2. compiler.sx catch clause: inject `(let ((var (host-hs-normalize-exc var))) ...)`
around the catch body so the sentinel gets swapped for the real error
object before user code runs. Uses let (not set!) so shadowing works
correctly for guard catch variables.
3. tests/hs-run-filtered.js:
- host-promise-state wraps JS Error objects as plain {message:...} dicts
before they cross the WASM boundary (Error.toString() was producing
"Error: boom" strings instead of accessible objects)
- host-hs-normalize-exc native retrieves the side-channel value when
the sentinel arrives in a catch variable
- host-get coercion restricted to El instances — plain JS objects with
a "value" key were being stringified to "[object Object]"
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
3016 lines
86 KiB
Plaintext
3016 lines
86 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 meta (host-new "Object"))
|
|
|
|
;; ── 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-caller
|
|
(let
|
|
((_ctx (host-new "Object"))
|
|
(_m (host-new "Object"))
|
|
(_f (host-new "Object")))
|
|
(do
|
|
(host-set! _f "type" "onFeature")
|
|
(host-set! _m "feature" _f)
|
|
(host-set! _ctx "meta" _m)
|
|
_ctx)))
|
|
|
|
;; Wait for a DOM event on a target.
|
|
;; (hs-wait-for target event-name) — suspends until event fires
|
|
(define
|
|
hs-on
|
|
(fn
|
|
(target event-name handler)
|
|
(let
|
|
((wrapped (fn (event) (do (host-set! meta "caller" _hs-on-caller) (host-set! meta "owner" target) (let ((__hs-no-stop false)) (guard (e ((and (not (= event-name "exception")) (not (= event-name "error"))) (do (when (and (list? e) (= (first e) "hs-halt-default")) (set! __hs-no-stop true)) (when (not __hs-no-stop) (dom-dispatch target "exception" {:error e})))) (true (raise e))) (handler event)) (when (not __hs-no-stop) (host-call event "stopPropagation")))))))
|
|
(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))))
|
|
|
|
;; Wait for CSS transitions/animations to settle on an element.
|
|
(define
|
|
hs-on-every
|
|
(fn (target event-name handler) (dom-listen target event-name handler)))
|
|
|
|
;; ── Class manipulation ──────────────────────────────────────────
|
|
|
|
;; Toggle a single class on an element.
|
|
(define
|
|
hs-on-intersection-attach!
|
|
(fn
|
|
(target margin threshold)
|
|
(let
|
|
((opts (dict)))
|
|
(when margin (dict-set! opts "rootMargin" margin))
|
|
(when threshold (dict-set! opts "threshold" threshold))
|
|
(let
|
|
((cb (fn (entries observer) (let ((entry (if (> (len entries) 0) (nth entries 0) nil))) (when entry (let ((intersecting (host-get entry "isIntersecting"))) (dom-dispatch target "intersection" (dict "intersecting" intersecting "entry" entry))))))))
|
|
(let
|
|
((observer (host-new "IntersectionObserver" cb opts)))
|
|
(host-call observer "observe" target)
|
|
observer)))))
|
|
|
|
;; Toggle between two classes — exactly one is active at a time.
|
|
(define
|
|
hs-on-mutation-attach!
|
|
(fn
|
|
(target mode attr-list)
|
|
(let
|
|
((cfg-attributes (or (= mode "any") (= mode "attributes") (= mode "attrs")))
|
|
(cfg-childList (or (= mode "any") (= mode "childList")))
|
|
(cfg-characterData (or (= mode "any") (= mode "characterData"))))
|
|
(let
|
|
((opts (dict "attributes" cfg-attributes "childList" cfg-childList "characterData" cfg-characterData "subtree" true)))
|
|
(when
|
|
(and (= mode "attrs") attr-list)
|
|
(dict-set! opts "attributeFilter" attr-list))
|
|
(let
|
|
((cb (fn (records observer) (dom-dispatch target "mutation" (dict "records" records)))))
|
|
(let
|
|
((observer (host-new "MutationObserver" cb)))
|
|
(host-call observer "observe" target opts)
|
|
observer))))))
|
|
|
|
;; Take a class from siblings — add to target, remove from others.
|
|
;; (hs-take! target cls) — like radio button class behavior
|
|
(define hs-init (fn (thunk) (thunk)))
|
|
|
|
;; ── DOM insertion ───────────────────────────────────────────────
|
|
|
|
;; Put content at a position relative to a target.
|
|
;; pos: "into" | "before" | "after"
|
|
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
|
|
|
|
;; ── Navigation / traversal ──────────────────────────────────────
|
|
|
|
;; Navigate to a URL.
|
|
(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)))))
|
|
|
|
;; Find next sibling matching a selector (or any sibling).
|
|
(define
|
|
hs-settle
|
|
(fn
|
|
(target)
|
|
(hs-null-raise! target)
|
|
(when (not (nil? target)) (perform (list (quote io-settle) target)))))
|
|
|
|
;; Find previous sibling matching a selector.
|
|
(define
|
|
hs-toggle-class!
|
|
(fn
|
|
(target cls)
|
|
(hs-null-raise! target)
|
|
(when
|
|
(not (nil? target))
|
|
(host-call (host-get target "classList") "toggle" cls))))
|
|
|
|
;; First element matching selector within a scope.
|
|
(define
|
|
hs-toggle-var-cycle!
|
|
(fn
|
|
(win var-name values)
|
|
(let
|
|
((current (host-get win var-name)) (n (len values)))
|
|
(define
|
|
find-idx
|
|
(fn
|
|
(i)
|
|
(if
|
|
(>= i n)
|
|
-1
|
|
(if (= (nth values i) current) i (find-idx (+ i 1))))))
|
|
(let
|
|
((idx (find-idx 0)))
|
|
(host-set!
|
|
win
|
|
var-name
|
|
(if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
|
|
|
|
;; Last element matching selector.
|
|
(define
|
|
hs-toggle-between!
|
|
(fn
|
|
(target cls1 cls2)
|
|
(hs-null-raise! target)
|
|
(when
|
|
(not (nil? target))
|
|
(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))))))
|
|
|
|
;; First/last within a specific scope.
|
|
(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 "")))))))
|
|
|
|
(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)))))
|
|
|
|
;; ── Iteration ───────────────────────────────────────────────────
|
|
|
|
;; Repeat a thunk N times.
|
|
(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)))))
|
|
|
|
;; Repeat forever (until break — relies on exception/continuation).
|
|
(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 ""))))))))
|
|
|
|
;; ── Fetch ───────────────────────────────────────────────────────
|
|
|
|
;; Fetch a URL, parse response according to format.
|
|
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
|
(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)
|
|
(hs-null-raise! el)
|
|
(when
|
|
(not (nil? el))
|
|
(if (nil? val) (dom-remove-attr el name) (dom-set-attr el name val)))))
|
|
(define
|
|
hs-toggle-attr!
|
|
(fn
|
|
(el name)
|
|
(hs-null-raise! el)
|
|
(when
|
|
(not (nil? el))
|
|
(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
|
|
(hs-null-raise! target)
|
|
(when
|
|
(not (nil? target))
|
|
(let
|
|
((str-val (if (list? value) (join "" (map (fn (x) (str x)) value)) (if (= value nil) "null" (str value)))))
|
|
(do
|
|
(dom-set-inner-html target str-val)
|
|
(hs-boot-subtree! target)))))))
|
|
(define
|
|
hs-set-element!
|
|
(fn
|
|
(target value)
|
|
(let
|
|
((parent (dom-parent target)))
|
|
(when
|
|
parent
|
|
(let
|
|
((tmp (dom-create-element "div"))
|
|
(str-val
|
|
(if
|
|
(list? value)
|
|
(join "" (map (fn (x) (str x)) value))
|
|
value)))
|
|
(do
|
|
(dom-set-inner-html tmp str-val)
|
|
(let
|
|
((children (host-get tmp "children")))
|
|
(if
|
|
(> (len children) 0)
|
|
(let
|
|
((new-el (first children)))
|
|
(do
|
|
(host-call parent "replaceChild" new-el target)
|
|
(hs-boot-subtree! new-el)))
|
|
(hs-set-inner-html! target str-val)))))))))
|
|
(define
|
|
hs-put!
|
|
(fn
|
|
(value pos target)
|
|
(do
|
|
(hs-null-raise! target)
|
|
(when
|
|
(not (nil? target))
|
|
(cond
|
|
((= pos "innerHTML")
|
|
(cond
|
|
((list? value) 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 "beforebegin")
|
|
(if
|
|
(hs-element? value)
|
|
(let
|
|
((parent (host-get target "parentNode")))
|
|
(when parent (host-call parent "insertBefore" value target)))
|
|
(let
|
|
((parent (host-get target "parentNode")))
|
|
(do
|
|
(dom-insert-adjacent-html target "beforebegin" value)
|
|
(when parent (hs-boot-subtree! parent))))))
|
|
((= pos "afterend")
|
|
(if
|
|
(hs-element? value)
|
|
(let
|
|
((parent (host-get target "parentNode"))
|
|
(next (host-get target "nextSibling")))
|
|
(when
|
|
parent
|
|
(if
|
|
next
|
|
(host-call parent "insertBefore" value next)
|
|
(host-call parent "appendChild" value))))
|
|
(let
|
|
((parent (host-get target "parentNode")))
|
|
(do
|
|
(dom-insert-adjacent-html target "afterend" value)
|
|
(when parent (hs-boot-subtree! parent))))))
|
|
((= pos "afterbegin")
|
|
(cond
|
|
((list? value) (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 "beforeend")
|
|
(cond
|
|
((list? value) (append! target value))
|
|
((hs-element? value) (dom-append target value))
|
|
(true
|
|
(do
|
|
(dom-insert-adjacent-html target "beforeend" value)
|
|
(hs-boot-subtree! target)))))))))))
|
|
|
|
;; ── Type coercion ───────────────────────────────────────────────
|
|
|
|
;; Coerce a value to a type by name.
|
|
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
|
(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)))))
|
|
|
|
;; ── Object creation ─────────────────────────────────────────────
|
|
|
|
;; Make a new object of a given type.
|
|
;; (hs-make type-name) — creates empty object/collection
|
|
(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))))
|
|
|
|
;; ── 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-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))))
|
|
|
|
;; ── 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-index
|
|
(fn
|
|
(obj key)
|
|
(cond
|
|
((nil? obj) nil)
|
|
((dict? obj) (get obj key))
|
|
((list? obj) (nth obj key))
|
|
((string? obj) (nth obj key))
|
|
(true (host-get obj key)))))
|
|
|
|
;; 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-put-at!
|
|
(fn
|
|
(value pos target)
|
|
(cond
|
|
((nil? target) (list value))
|
|
((list? target)
|
|
(if
|
|
(= pos "start")
|
|
(cons value target)
|
|
(append target (list value))))
|
|
(true
|
|
(cond
|
|
((hs-element? target) (do (hs-put! value pos target) target))
|
|
(true
|
|
(do
|
|
(cond
|
|
((= pos "end") (host-call target "push" value))
|
|
((= pos "start") (host-call target "unshift" value)))
|
|
target)))))))
|
|
|
|
|
|
;; ── Transition ──────────────────────────────────────────────────
|
|
|
|
;; Transition a CSS property to a value, optionally with duration.
|
|
;; (hs-transition target prop value duration)
|
|
(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)))))
|
|
|
|
(define
|
|
hs-set-on!
|
|
(fn
|
|
(props target)
|
|
(for-each (fn (k) (host-set! target k (get props k))) (keys props))))
|
|
|
|
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
|
|
|
|
(define
|
|
hs-ask
|
|
(fn
|
|
(msg)
|
|
(let
|
|
((w (host-global "window")))
|
|
(if w (host-call w "prompt" msg) nil))))
|
|
|
|
(define
|
|
hs-answer
|
|
(fn
|
|
(msg yes-val no-val)
|
|
(let
|
|
((w (host-global "window")))
|
|
(if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
|
|
|
|
(define
|
|
hs-answer-alert
|
|
(fn
|
|
(msg)
|
|
(let
|
|
((w (host-global "window")))
|
|
(if w (begin (host-call w "alert" msg) nil) nil))))
|
|
|
|
(define
|
|
hs-scroll!
|
|
(fn
|
|
(target position)
|
|
(host-call
|
|
target
|
|
"scrollIntoView"
|
|
(list
|
|
(cond
|
|
((= position "bottom") (dict :block "end"))
|
|
(true (dict :block "start")))))))
|
|
|
|
(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 (if (= mode "default") "hs-halt-default" "hs-return") nil))))))
|
|
|
|
(define hs-select! (fn (target) (host-call target "select" (list))))
|
|
|
|
(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)))))
|
|
;; ── Sandbox/test runtime additions ──────────────────────────────
|
|
;; Property access — dot notation and .length
|
|
(define _hs-last-query-sel nil)
|
|
;; DOM query stub — sandbox returns empty list
|
|
(define
|
|
hs-null-raise!
|
|
(fn
|
|
(v)
|
|
(when
|
|
(nil? v)
|
|
(let
|
|
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
|
(host-set! (host-global "window") "_hs_null_error" msg)
|
|
(guard (_null-e (true nil)) (raise msg))))))
|
|
;; Method dispatch — obj.method(args)
|
|
(define
|
|
hs-empty-raise!
|
|
(fn
|
|
(v)
|
|
(when
|
|
(or
|
|
(nil? v)
|
|
(and (list? v) (= (len v) 0))
|
|
(= (host-get v "length") 0))
|
|
(let
|
|
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
|
(host-set! (host-global "window") "_hs_null_error" msg)
|
|
(guard (_null-e (true nil)) (raise msg))))))
|
|
|
|
;; ── 0.9.90 features ─────────────────────────────────────────────
|
|
;; beep! — debug logging, returns value unchanged
|
|
(define
|
|
hs-query-all-checked
|
|
(fn
|
|
(sel)
|
|
(let
|
|
((result (hs-query-all sel)))
|
|
(do (hs-empty-raise! result) result))))
|
|
;; Property-based is — check obj.key truthiness
|
|
(define
|
|
hs-dispatch!
|
|
(fn
|
|
(target event detail)
|
|
(hs-null-raise! target)
|
|
(when (not (nil? target)) (dom-dispatch target event detail))))
|
|
;; Array slicing (inclusive both ends)
|
|
(define
|
|
hs-query-all
|
|
(fn
|
|
(sel)
|
|
(do
|
|
(host-set! (host-global "window") "_hs_last_query_sel" sel)
|
|
(dom-query-all (dom-document) sel))))
|
|
;; Collection: sorted by
|
|
(define
|
|
hs-query-all-in
|
|
(fn
|
|
(sel target)
|
|
(if
|
|
(nil? target)
|
|
(hs-query-all sel)
|
|
(host-call target "querySelectorAll" sel))))
|
|
;; Collection: sorted by descending
|
|
(define
|
|
hs-list-set
|
|
(fn
|
|
(lst idx val)
|
|
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
|
|
;; Collection: split by
|
|
(define
|
|
hs-to-number
|
|
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
|
|
;; Collection: joined by
|
|
(define
|
|
hs-query-first
|
|
(fn
|
|
(sel)
|
|
(do
|
|
(host-set! (host-global "window") "_hs_last_query_sel" 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
|
|
((ex nil) (raised false))
|
|
(do
|
|
(guard
|
|
(e (true (do (set! ex e) (set! raised true) nil)))
|
|
(do (thunk) nil))
|
|
(cond
|
|
((not raised) (do-repeat (+ i 1)))
|
|
((= (str ex) "hs-break") nil)
|
|
((= (str ex) "hs-continue") (do-repeat (+ i 1)))
|
|
(true (raise ex))))))))
|
|
(do-repeat 0)))
|
|
|
|
(define
|
|
hs-repeat-forever
|
|
(fn
|
|
(thunk)
|
|
(define
|
|
do-forever
|
|
(fn
|
|
()
|
|
(let
|
|
((ex nil) (raised false))
|
|
(do
|
|
(guard
|
|
(e (true (do (set! ex e) (set! raised true) nil)))
|
|
(do (thunk) nil))
|
|
(cond
|
|
((not raised) (do-forever))
|
|
((= (str ex) "hs-break") nil)
|
|
((= (str ex) "hs-continue") (do-forever))
|
|
(true (raise ex)))))))
|
|
(do-forever)))
|
|
|
|
(define
|
|
hs-repeat-while
|
|
(fn
|
|
(cond-fn thunk)
|
|
(when
|
|
(cond-fn)
|
|
(let
|
|
((ex nil) (raised false))
|
|
(do
|
|
(guard
|
|
(e (true (do (set! ex e) (set! raised true) nil)))
|
|
(do (thunk) nil))
|
|
(cond
|
|
((not raised) (hs-repeat-while cond-fn thunk))
|
|
((= (str ex) "hs-break") nil)
|
|
((= (str ex) "hs-continue") (hs-repeat-while cond-fn thunk))
|
|
(true (raise ex))))))))
|
|
|
|
(define
|
|
hs-repeat-until
|
|
(fn
|
|
(cond-fn thunk)
|
|
(let
|
|
((ex nil) (raised false))
|
|
(do
|
|
(guard
|
|
(e (true (do (set! ex e) (set! raised true) nil)))
|
|
(do (thunk) nil))
|
|
(cond
|
|
((not raised) (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
|
|
((= (str ex) "hs-break") nil)
|
|
((= (str ex) "hs-continue")
|
|
(if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
|
|
(true (raise ex)))))))
|
|
|
|
(define
|
|
hs-for-each
|
|
(fn
|
|
(fn-body collection)
|
|
(let
|
|
((items (cond ((list? collection) collection) ((nil? collection) (list)) ((host-iter? collection) (host-to-list collection)) ((dict? collection) (if (dict-has? collection "_order") (get collection "_order") (filter (fn (k) (not (= k "_order"))) (keys collection)))) (true (list)))))
|
|
(define
|
|
do-loop
|
|
(fn
|
|
(remaining)
|
|
(when
|
|
(not (empty? remaining))
|
|
(let
|
|
((ex nil) (raised false))
|
|
(do
|
|
(guard
|
|
(e (true (do (set! ex e) (set! raised true) nil)))
|
|
(do (fn-body (first remaining)) nil))
|
|
(cond
|
|
((not raised) (do-loop (rest remaining)))
|
|
((= (str ex) "hs-break") nil)
|
|
((= (str ex) "hs-continue") (do-loop (rest remaining)))
|
|
(true (raise ex))))))))
|
|
(do-loop items))))
|
|
|
|
(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"
|
|
(if
|
|
(hs-element? value)
|
|
(host-get value "outerHTML")
|
|
(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"
|
|
(if
|
|
(hs-element? value)
|
|
(host-get value "outerHTML")
|
|
(str value))))
|
|
(true nil)))))
|
|
|
|
(define
|
|
hs-sender
|
|
(fn
|
|
(event)
|
|
(let
|
|
((detail (host-get event "detail")))
|
|
(if detail (host-get detail "sender") nil))))
|
|
|
|
(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)))))))))))
|
|
|
|
(define
|
|
hs-fetch-impl
|
|
(fn
|
|
(url format no-throw)
|
|
(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") ((or (= format "number") (= format "Number")) "number") (true "text"))))
|
|
(let
|
|
((_hs-before-caller (host-get meta "owner")))
|
|
(when
|
|
_hs-before-caller
|
|
(dom-dispatch _hs-before-caller "hyperscript:beforeFetch" {:url url})))
|
|
(let
|
|
((raw (perform (list "io-fetch" url fmt))))
|
|
(begin
|
|
(when
|
|
(= (host-get raw "_network-error") true)
|
|
(raise (or (host-get raw "message") "Network error")))
|
|
(when
|
|
(and
|
|
(not no-throw)
|
|
(not (= fmt "response"))
|
|
(= (host-get raw "ok") false))
|
|
(raise (str "HTTP Error: " (host-get raw "status"))))
|
|
(cond
|
|
((= fmt "response") raw)
|
|
((= fmt "json")
|
|
(hs-host-to-sx (perform (list "io-parse-json" raw))))
|
|
((= fmt "number")
|
|
(hs-to-number (perform (list "io-parse-text" raw))))
|
|
(true (perform (list "io-parse-text" raw)))))))))
|
|
|
|
(define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
|
|
|
|
(define hs-fetch-no-throw (fn (url format) (hs-fetch-impl url format true)))
|
|
|
|
(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)
|
|
"\"")))
|
|
|
|
(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)) (hs-host-to-sx (json-parse value))))
|
|
((not (nil? (host-get value "_json")))
|
|
(hs-host-to-sx (perform (list "io-parse-json" value))))
|
|
((dict? value) 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 (filter (fn (k) (not (= k "_order"))) (keys value)))
|
|
value))
|
|
((= type-name "Entries")
|
|
(if
|
|
(dict? value)
|
|
(let
|
|
((ks (if (dict-has? value "_order") (get value "_order") (filter (fn (k) (not (= k "_order"))) (keys value)))))
|
|
(map (fn (k) (list k (get value k))) ks))
|
|
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)
|
|
(let
|
|
((ks (if (dict-has? value "_order") (get value "_order") (filter (fn (k) (not (= k "_order"))) (keys value)))))
|
|
(map (fn (k) (list k (get value k))) ks))
|
|
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)
|
|
(let
|
|
((idx (host-get node "selectedIndex"))
|
|
(opts (host-get node "options"))
|
|
(raw-val (host-get node "value")))
|
|
(if
|
|
(and (not (nil? raw-val)) (not (= raw-val "")))
|
|
raw-val
|
|
(if
|
|
(and (not (nil? opts)) (>= idx 0))
|
|
(host-get
|
|
(if (list? opts) (nth opts idx) (host-get opts idx))
|
|
"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)
|
|
(hs-null-raise! target)
|
|
(when (not (nil? target)) (perform (list (quote io-measure) target)))))
|
|
|
|
(define
|
|
hs-transition
|
|
(fn
|
|
(target prop value duration)
|
|
(hs-null-raise! target)
|
|
(when
|
|
(not (nil? target))
|
|
(let
|
|
((init-attr (str "data-hs-transition-" prop)))
|
|
(when
|
|
(not (dom-get-attr target init-attr))
|
|
(dom-set-attr target init-attr (dom-get-style target prop)))
|
|
(let
|
|
((actual-value (if (= value "initial") (dom-get-attr target init-attr) value)))
|
|
(when
|
|
duration
|
|
(dom-set-style
|
|
target
|
|
"transition"
|
|
(str prop " " (/ duration 1000) "s")))
|
|
(dom-set-style target prop actual-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-id=
|
|
(fn
|
|
(a b)
|
|
(if
|
|
(and (= (host-typeof a) "element") (= (host-typeof b) "element"))
|
|
(hs-ref-eq a 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-in?
|
|
(fn
|
|
(collection item)
|
|
(cond
|
|
((nil? collection) (list))
|
|
((list? collection)
|
|
(cond
|
|
((nil? item) (list))
|
|
((list? item)
|
|
(filter (fn (x) (hs-contains? collection x)) item))
|
|
((hs-contains? collection item) (list item))
|
|
(true (list))))
|
|
(true (list)))))
|
|
|
|
(define
|
|
hs-in-bool?
|
|
(fn (collection item) (not (hs-falsy? (hs-in? collection item)))))
|
|
|
|
(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)
|
|
(hs-empty-raise! target)
|
|
(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)
|
|
(hs-empty-raise! target)
|
|
(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)
|
|
(let
|
|
((name (first pair)))
|
|
(do
|
|
(dict-set! d name (nth pair 1))
|
|
(dict-set!
|
|
d
|
|
"_order"
|
|
(append (or (get d "_order") (list)) (list name))))))
|
|
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
|
|
(let
|
|
((fn-val (host-get obj method)))
|
|
(cond
|
|
((and fn-val (callable? fn-val)) (apply fn-val args))
|
|
(fn-val (apply host-call (cons obj (cons method args))))
|
|
(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)
|
|
(true
|
|
(let
|
|
((m (if (nil? n) 1 n)))
|
|
(cond
|
|
((string? col) (slice col 0 m))
|
|
((list? col) (slice col 0 m))
|
|
(true col)))))))
|
|
|
|
(define
|
|
hs-pick-last
|
|
(fn
|
|
(col n)
|
|
(cond
|
|
((nil? col) nil)
|
|
(true
|
|
(let
|
|
((total (cond ((string? col) (len col)) ((list? col) (len col)) (true 0))))
|
|
(let
|
|
((start (max 0 (- total n))))
|
|
(cond
|
|
((string? col) (slice col start total))
|
|
((list? col) (slice col start total))
|
|
(true col))))))))
|
|
|
|
(define
|
|
hs-pick-random
|
|
(fn
|
|
(col n)
|
|
(cond
|
|
((nil? col) nil)
|
|
(true
|
|
(let
|
|
((total (cond ((string? col) (len col)) ((list? col) (len col)) (true 0))))
|
|
(cond
|
|
((= total 0) (if (nil? n) nil (list)))
|
|
((nil? n) (nth col 0))
|
|
(true
|
|
(let
|
|
((m (max 0 (if (> n total) total n))))
|
|
(cond
|
|
((string? col) (slice col 0 m))
|
|
((list? col) (slice col 0 m))
|
|
(true col))))))))))
|
|
|
|
(define
|
|
hs-pick-items
|
|
(fn
|
|
(col start end)
|
|
(cond
|
|
((nil? col) nil)
|
|
(true
|
|
(let
|
|
((n (cond ((string? col) (len col)) ((list? col) (len col)) (true 0))))
|
|
(let
|
|
((s (cond ((= start "hs-pick-start") 0) ((= start "hs-pick-end") n) ((and (number? start) (< start 0)) (max 0 (+ n start))) (true start)))
|
|
(e
|
|
(cond
|
|
((= end "hs-pick-end") n)
|
|
((= end "hs-pick-start") 0)
|
|
((and (number? end) (< end 0)) (max 0 (+ n end)))
|
|
(true end))))
|
|
(cond
|
|
((string? col) (slice col s e))
|
|
((list? col) (slice col s e))
|
|
(true col))))))))
|
|
|
|
(define
|
|
hs-pick-match
|
|
(fn
|
|
(regex haystack)
|
|
(cond
|
|
((nil? regex) nil)
|
|
((nil? haystack) nil)
|
|
(true (regex-match (hs-pick-regex-pattern regex) haystack)))))
|
|
|
|
(begin
|
|
(define
|
|
hs-pick-regex-ci-char
|
|
(fn
|
|
(ch)
|
|
(let
|
|
((lo (lower ch)) (up (upper ch)))
|
|
(if (= lo up) ch (str "[" lo up "]")))))
|
|
(define
|
|
hs-pick-regex-ci
|
|
(fn
|
|
(pat)
|
|
(let
|
|
((n (len pat)) (out ""))
|
|
(let
|
|
((i 0))
|
|
(let
|
|
((loop (fn () nil)))
|
|
(do
|
|
(set!
|
|
loop
|
|
(fn
|
|
()
|
|
(cond
|
|
((>= i n) nil)
|
|
(true
|
|
(let
|
|
((ch (char-at pat i)))
|
|
(cond
|
|
((= ch "\\")
|
|
(do
|
|
(set! out (str out ch))
|
|
(set! i (+ i 1))
|
|
(when
|
|
(< i n)
|
|
(set! out (str out (char-at pat i)))
|
|
(set! i (+ i 1)))
|
|
(loop)))
|
|
(true
|
|
(do
|
|
(set! out (str out (hs-pick-regex-ci-char ch)))
|
|
(set! i (+ i 1))
|
|
(loop)))))))))
|
|
(loop)
|
|
out))))))
|
|
(define
|
|
hs-pick-regex-pattern
|
|
(fn
|
|
(regex)
|
|
(cond
|
|
((nil? regex) "")
|
|
((list? regex)
|
|
(let
|
|
((pat (nth regex 0)) (flags (nth regex 1)))
|
|
(cond
|
|
((nil? flags) pat)
|
|
((string-contains? flags "i") (hs-pick-regex-ci pat))
|
|
(true pat))))
|
|
(true regex)))))
|
|
|
|
(define
|
|
hs-pick-matches
|
|
(fn
|
|
(regex haystack)
|
|
(cond
|
|
((nil? regex) nil)
|
|
((nil? haystack) nil)
|
|
(true
|
|
(let
|
|
((pat (hs-pick-regex-pattern regex)))
|
|
(let
|
|
((found (regex-find-all pat haystack)))
|
|
(map (fn (m) (list m)) found)))))))
|
|
|
|
(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)))))
|
|
|
|
;; ── SourceInfo API ────────────────────────────────────────────────
|
|
|
|
(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))))))
|
|
|
|
(define
|
|
hs-win-call
|
|
(fn
|
|
(fn-name args)
|
|
(let
|
|
((fn (host-get (host-global "window") fn-name)))
|
|
(if
|
|
fn
|
|
(let
|
|
((result (host-call-fn fn args)))
|
|
(if
|
|
(= (host-typeof result) "promise")
|
|
(let
|
|
((state (host-promise-state result)))
|
|
(if
|
|
(and state (= (host-get state "ok") false))
|
|
(do
|
|
(host-set!
|
|
(host-global "window")
|
|
"__hs_async_error"
|
|
(host-get state "value"))
|
|
(raise "__hs_async_error__"))
|
|
(if state (host-get state "value") result)))
|
|
result))
|
|
(let
|
|
((msg (str "'" fn-name "' is null")))
|
|
(host-set! (host-global "window") "_hs_null_error" msg)
|
|
(guard (_null-e (true nil)) (raise msg)))))))
|
|
|
|
(define
|
|
hs-source-for
|
|
(fn
|
|
(node)
|
|
(substring (get node :src) (get node :start) (get node :end))))
|
|
|
|
(define
|
|
hs-line-for
|
|
(fn
|
|
(node)
|
|
(let
|
|
((lines (split (get node :src) "\n"))
|
|
(line-idx (- (get node :line) 1)))
|
|
(if (< line-idx (len lines)) (nth lines line-idx) ""))))
|
|
|
|
(define hs-node-get (fn (node key) (get (get node :fields) key)))
|
|
|
|
(define hs-src (fn (src-str) (hs-source-for (hs-parse-ast src-str))))
|
|
|
|
(define
|
|
hs-src-at
|
|
(fn
|
|
(src-str path)
|
|
(define
|
|
walk
|
|
(fn
|
|
(node keys)
|
|
(if
|
|
(or (nil? keys) (= (len keys) 0))
|
|
node
|
|
(walk (hs-node-get node (first keys)) (rest keys)))))
|
|
(hs-source-for (walk (hs-parse-ast src-str) path))))
|
|
|
|
(define
|
|
hs-line-at
|
|
(fn
|
|
(src-str path)
|
|
(define
|
|
walk
|
|
(fn
|
|
(node keys)
|
|
(if
|
|
(or (nil? keys) (= (len keys) 0))
|
|
node
|
|
(walk (hs-node-get node (first keys)) (rest keys)))))
|
|
(hs-line-for (walk (hs-parse-ast src-str) path))))
|
|
|
|
(define
|
|
hs-js-exec
|
|
(fn
|
|
(param-names js-src bound-args)
|
|
(let
|
|
((js-fn (host-new-function param-names js-src)))
|
|
(let
|
|
((result (host-call-fn js-fn bound-args)))
|
|
(if
|
|
(= (host-typeof result) "promise")
|
|
(let
|
|
((state (host-promise-state result)))
|
|
(if
|
|
(and state (= (host-get state "ok") false))
|
|
(raise (host-get state "value"))
|
|
(if state (host-get state "value") result)))
|
|
result)))))
|
|
|
|
(define
|
|
hs-raw->api-token
|
|
(fn
|
|
(raw)
|
|
(let
|
|
((type (dict-get raw :type)) (value (dict-get raw :value)))
|
|
(cond
|
|
(= type "ident")
|
|
{:value value :type "IDENTIFIER" :op false}
|
|
(= type "keyword")
|
|
{:value value :type "IDENTIFIER" :op false}
|
|
(= type "number")
|
|
{:value value :type "NUMBER" :op false}
|
|
(= type "string")
|
|
{:value value :type "STRING" :op false}
|
|
(= type "class")
|
|
{:value (str "." value) :type "CLASS_REF" :op false}
|
|
(= type "id")
|
|
{:value (str "#" value) :type "ID_REF" :op false}
|
|
(= type "attr")
|
|
{:value value :type "ATTRIBUTE_REF" :op false}
|
|
(= type "style")
|
|
{:value value :type "STYLE_REF" :op false}
|
|
(= type "selector")
|
|
{:value value :type "QUERY_REF" :op false}
|
|
(= type "eof")
|
|
{:value "<<<EOF>>>" :type "EOF" :op false}
|
|
(= type "paren-open")
|
|
{:value value :type "L_PAREN" :op true}
|
|
(= type "paren-close")
|
|
{:value value :type "R_PAREN" :op true}
|
|
(= type "bracket-open")
|
|
{:value value :type "L_BRACKET" :op true}
|
|
(= type "bracket-close")
|
|
{:value value :type "R_BRACKET" :op true}
|
|
(= type "brace-open")
|
|
{:value value :type "L_BRACE" :op true}
|
|
(= type "brace-close")
|
|
{:value value :type "R_BRACE" :op true}
|
|
(= type "comma")
|
|
{:value value :type "COMMA" :op true}
|
|
(= type "dot")
|
|
{:value value :type "PERIOD" :op true}
|
|
(= type "colon")
|
|
{:value value :type "COLON" :op true}
|
|
(= type "op")
|
|
(cond
|
|
(= value "+")
|
|
{:value value :type "PLUS" :op true}
|
|
(= value "-")
|
|
{:value value :type "MINUS" :op true}
|
|
(= value "*")
|
|
{:value value :type "MULTIPLY" :op true}
|
|
(= value "/")
|
|
{:value value :type "SLASH" :op true}
|
|
(= value "!")
|
|
{:value value :type "EXCLAMATION" :op true}
|
|
(= value "?")
|
|
{:value value :type "QUESTION" :op true}
|
|
(= value "#")
|
|
{:value value :type "POUND" :op true}
|
|
(= value "&")
|
|
{:value value :type "AMPERSAND" :op true}
|
|
(= value "=")
|
|
{:value value :type "EQUALS" :op true}
|
|
(= value "<")
|
|
{:value value :type "L_ANG" :op true}
|
|
(= value ">")
|
|
{:value value :type "R_ANG" :op true}
|
|
(= value "<=")
|
|
{:value value :type "LTE_ANG" :op true}
|
|
(= value ">=")
|
|
{:value value :type "GTE_ANG" :op true}
|
|
(= value "==")
|
|
{:value value :type "EQ" :op true}
|
|
(= value "===")
|
|
{:value value :type "EQQ" :op true}
|
|
(= value "..")
|
|
{:value value :type "PERIOD_PERIOD" :op true}
|
|
:else {:value value :type value :op true})
|
|
:else {:value (or value "") :type (str type) :op false}))))
|
|
|
|
(define hs-eof-sentinel {:value "<<<EOF>>>" :type "EOF" :op false})
|
|
|
|
(define
|
|
hs-tokens-of
|
|
(fn
|
|
(src &rest args)
|
|
(let
|
|
((template (some (fn (a) (equal? a :template)) args)))
|
|
(let
|
|
((raw (if template (hs-tokenize-template src) (hs-tokenize src))))
|
|
{:pos 0 :list (filter (fn (t) (not (= (dict-get t :type) "EOF"))) (map hs-raw->api-token raw)) :source src}))))
|
|
|
|
(define
|
|
hs-stream-token
|
|
(fn
|
|
(s i)
|
|
(let
|
|
((lst (dict-get s :list)) (n (len (dict-get s :list))))
|
|
(define
|
|
find
|
|
(fn
|
|
(pos count)
|
|
(if
|
|
(>= pos n)
|
|
hs-eof-sentinel
|
|
(let
|
|
((tok (nth lst pos)))
|
|
(if
|
|
(= (dict-get tok :type) "whitespace")
|
|
(find (+ pos 1) count)
|
|
(if (= count 0) tok (find (+ pos 1) (- count 1))))))))
|
|
(find (dict-get s :pos) i))))
|
|
|
|
(define
|
|
hs-stream-consume
|
|
(fn
|
|
(s)
|
|
(let
|
|
((lst (dict-get s :list)) (n (len (dict-get s :list))))
|
|
(define
|
|
find-pos
|
|
(fn
|
|
(pos)
|
|
(if
|
|
(>= pos n)
|
|
pos
|
|
(if
|
|
(= (dict-get (nth lst pos) :type) "whitespace")
|
|
(find-pos (+ pos 1))
|
|
pos))))
|
|
(let
|
|
((p (find-pos (dict-get s :pos))))
|
|
(let
|
|
((tok (if (>= p n) hs-eof-sentinel (nth lst p))))
|
|
(do
|
|
(when
|
|
(not (= (dict-get tok :type) "EOF"))
|
|
(dict-set! s :pos (+ p 1)))
|
|
tok))))))
|
|
|
|
(define
|
|
hs-stream-has-more
|
|
(fn (s) (not (= (dict-get (hs-stream-token s 0) :type) "EOF"))))
|
|
|
|
(define hs-token-type (fn (tok) (dict-get tok :type)))
|
|
|
|
(define hs-token-value (fn (tok) (dict-get tok :value)))
|
|
|
|
(define hs-token-op? (fn (tok) (dict-get tok :op)))
|