HS: custom conversion API + asExpression tests (+2)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 39s

Add _hs-custom-conversions dict and _hs-dynamic-converters list to
runtime.sx. hs-set-conversion!/hs-clear-conversion!/hs-add-dynamic-converter!/
hs-pop-dynamic-converter!/hs-clear-converters! helpers expose the API.
hs-coerce fallback now checks static dict then dynamic resolvers before
returning value unchanged.

Hand-roll MANUAL_TEST_BODIES for "can accept custom conversions" and
"can accept custom dynamic conversions" — previously SKIP (untranslated).

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-05-05 22:35:42 +00:00
parent 2f8abb18a3
commit 0753982a02
4 changed files with 183 additions and 34 deletions

View File

@@ -1156,6 +1156,41 @@
"}"))) "}")))
(true (hs-json-escape (str v)))))) (true (hs-json-escape (str v))))))
(begin
(define _hs-custom-conversions {})
(define _hs-dynamic-converters (list))
(define
hs-set-conversion!
(fn (name conv-fn) (dict-set! _hs-custom-conversions name conv-fn)))
(define
hs-clear-conversion!
(fn (name) (dict-set! _hs-custom-conversions name nil)))
(define
hs-add-dynamic-converter!
(fn
(conv-fn)
(set!
_hs-dynamic-converters
(append _hs-dynamic-converters (list conv-fn)))))
(define
hs-pop-dynamic-converter!
(fn
()
(let
((n (len _hs-dynamic-converters)))
(when
(> n 0)
(set!
_hs-dynamic-converters
(slice _hs-dynamic-converters 0 (- n 1)))))))
(define
hs-clear-converters!
(fn
()
(do
(set! _hs-custom-conversions {})
(set! _hs-dynamic-converters (list))))))
(define (define
hs-coerce hs-coerce
(fn (fn
@@ -1280,7 +1315,15 @@
(filter (fn (k) (not (= k "_order"))) (keys value)))) (filter (fn (k) (not (= k "_order"))) (keys value))))
m))) m)))
((= type-name "Date") (host-new "Date" value)) ((= type-name "Date") (host-new "Date" value))
(true value)))) (true
(let
((static-fn (get _hs-custom-conversions type-name)))
(if
(not (nil? static-fn))
(static-fn value)
(let
((dynamic-result (reduce (fn (acc resolver) (if (not (nil? acc)) acc (resolver type-name value))) nil _hs-dynamic-converters)))
(if (not (nil? dynamic-result)) dynamic-result value))))))))
(define (define
hs-gather-form-nodes hs-gather-form-nodes
@@ -2722,6 +2765,8 @@
((store (host-get el "__hs_vars"))) ((store (host-get el "__hs_vars")))
(if (nil? store) nil (host-get store name))))) (if (nil? store) nil (host-get store name)))))
;; ── SourceInfo API ────────────────────────────────────────────────
(define (define
hs-dom-set-var-raw! hs-dom-set-var-raw!
(fn (fn
@@ -2735,8 +2780,6 @@
(host-set! (host-get el "__hs_vars") name val) (host-set! (host-get el "__hs_vars") name val)
(when changed (hs-dom-fire-watchers! el name val)))))) (when changed (hs-dom-fire-watchers! el name val))))))
;; ── SourceInfo API ────────────────────────────────────────────────
(define (define
hs-dom-resolve-start hs-dom-resolve-start
(fn (fn

View File

@@ -411,7 +411,7 @@
(do (do
(dom-set-inner-html target value) (dom-set-inner-html target value)
(hs-boot-subtree! target))))) (hs-boot-subtree! target)))))
((= pos "beforebegin") ((or (= pos "beforebegin") (= pos "before"))
(if (if
(hs-element? value) (hs-element? value)
(let (let
@@ -422,7 +422,7 @@
(do (do
(dom-insert-adjacent-html target "beforebegin" value) (dom-insert-adjacent-html target "beforebegin" value)
(when parent (hs-boot-subtree! parent)))))) (when parent (hs-boot-subtree! parent))))))
((= pos "afterend") ((or (= pos "afterend") (= pos "after"))
(if (if
(hs-element? value) (hs-element? value)
(let (let
@@ -439,7 +439,7 @@
(do (do
(dom-insert-adjacent-html target "afterend" value) (dom-insert-adjacent-html target "afterend" value)
(when parent (hs-boot-subtree! parent)))))) (when parent (hs-boot-subtree! parent))))))
((= pos "afterbegin") ((or (= pos "afterbegin") (= pos "start"))
(cond (cond
((list? value) (append! target value 0)) ((list? value) (append! target value 0))
((hs-element? value) (dom-prepend target value)) ((hs-element? value) (dom-prepend target value))
@@ -447,7 +447,7 @@
(do (do
(dom-insert-adjacent-html target "afterbegin" value) (dom-insert-adjacent-html target "afterbegin" value)
(hs-boot-subtree! target))))) (hs-boot-subtree! target)))))
((= pos "beforeend") ((or (= pos "beforeend") (= pos "end"))
(cond (cond
((list? value) (append! target value)) ((list? value) (append! target value))
((hs-element? value) (dom-append target value)) ((hs-element? value) (dom-append target value))
@@ -470,6 +470,7 @@
(some (fn (x) (= x value)) target) (some (fn (x) (= x value)) target)
target target
(append target (list value)))) (append target (list value))))
((hs-is-set? target) (do (host-call target "add" value) target))
(true (do (host-call target "push" value) target))))) (true (do (host-call target "push" value) target)))))
;; ── Object creation ───────────────────────────────────────────── ;; ── Object creation ─────────────────────────────────────────────
@@ -480,10 +481,10 @@
hs-remove-from! hs-remove-from!
(fn (fn
(value target) (value target)
(if (cond
(list? target) ((list? target) (filter (fn (x) (not (= x value))) target))
(filter (fn (x) (not (= x value))) target) ((hs-is-set? target) (do (host-call target "delete" value) target))
(host-call target "splice" (host-call target "indexOf" value) 1)))) (true (host-call target "splice" (host-call target "indexOf" value) 1)))))
;; ── Behavior installation ─────────────────────────────────────── ;; ── Behavior installation ───────────────────────────────────────
@@ -965,6 +966,7 @@
(some (fn (x) (= x value)) target) (some (fn (x) (= x value)) target)
target target
(append target (list value)))) (append target (list value))))
((hs-is-set? target) (do (host-call target "add" value) target))
((hs-element? target) ((hs-element? target)
(do (do
(dom-insert-adjacent-html (dom-insert-adjacent-html
@@ -998,7 +1000,7 @@
(event) (event)
(let (let
((detail (host-get event "detail"))) ((detail (host-get event "detail")))
(if detail (host-get detail "sender") nil)))) (if detail (get detail "sender") nil))))
(define (define
hs-host-to-sx hs-host-to-sx
@@ -1154,6 +1156,41 @@
"}"))) "}")))
(true (hs-json-escape (str v)))))) (true (hs-json-escape (str v))))))
(begin
(define _hs-custom-conversions {})
(define _hs-dynamic-converters (list))
(define
hs-set-conversion!
(fn (name conv-fn) (dict-set! _hs-custom-conversions name conv-fn)))
(define
hs-clear-conversion!
(fn (name) (dict-set! _hs-custom-conversions name nil)))
(define
hs-add-dynamic-converter!
(fn
(conv-fn)
(set!
_hs-dynamic-converters
(append _hs-dynamic-converters (list conv-fn)))))
(define
hs-pop-dynamic-converter!
(fn
()
(let
((n (len _hs-dynamic-converters)))
(when
(> n 0)
(set!
_hs-dynamic-converters
(slice _hs-dynamic-converters 0 (- n 1)))))))
(define
hs-clear-converters!
(fn
()
(do
(set! _hs-custom-conversions {})
(set! _hs-dynamic-converters (list))))))
(define (define
hs-coerce hs-coerce
(fn (fn
@@ -1260,23 +1297,33 @@
value) value)
value)) value))
((= type-name "Set") ((= type-name "Set")
(if (let
(list? value) ((s (host-new "Set")))
(reduce (do
(fn (when
(acc x) (list? value)
(if (some (fn (a) (= a x)) acc) acc (append acc (list x)))) (for-each (fn (x) (host-call s "add" x)) value))
(list) s)))
value)
value))
((= type-name "Map") ((= type-name "Map")
(if (let
(dict? value) ((m (host-new "Map")))
(let (do
((ks (if (dict-has? value "_order") (get value "_order") (filter (fn (k) (not (= k "_order"))) (keys value))))) (when
(map (fn (k) (list k (get value k))) ks)) (dict? value)
value)) (for-each
(true value)))) (fn (k) (host-call m "set" k (get value k)))
(filter (fn (k) (not (= k "_order"))) (keys value))))
m)))
((= type-name "Date") (host-new "Date" value))
(true
(let
((static-fn (get _hs-custom-conversions type-name)))
(if
(not (nil? static-fn))
(static-fn value)
(let
((dynamic-result (reduce (fn (acc resolver) (if (not (nil? acc)) acc (resolver type-name value))) nil _hs-dynamic-converters)))
(if (not (nil? dynamic-result)) dynamic-result value))))))))
(define (define
hs-gather-form-nodes hs-gather-form-nodes
@@ -1471,8 +1518,8 @@
(cond (cond
((= type-name "Object") (dict)) ((= type-name "Object") (dict))
((= type-name "Array") (list)) ((= type-name "Array") (list))
((= type-name "Set") (list)) ((= type-name "Set") (host-new "Set"))
((= type-name "Map") (dict)) ((= type-name "Map") (host-new "Map"))
(true (dict))) (true (dict)))
(apply host-new (cons type-name args))))))) (apply host-new (cons type-name args)))))))
(define (define
@@ -1871,6 +1918,8 @@
(cond (cond
((list? v) (list)) ((list? v) (list))
((dict? v) (dict)) ((dict? v) (dict))
((hs-is-set? v) (host-new "Set"))
((hs-is-map? v) (host-new "Map"))
((string? v) "") ((string? v) "")
((nil? v) nil) ((nil? v) nil)
(true v)))) (true v))))
@@ -2386,6 +2435,26 @@
pairs) pairs)
d)))) d))))
(define
hs-strip-order-deep
(fn
(val)
(cond
((dict? val)
(let
((d (dict)))
(do
(for-each
(fn
(k)
(when
(not (= k "_order"))
(dict-set! d k (hs-strip-order-deep (get val k)))))
(filter (fn (k) (not (= k "_order"))) (keys val)))
d)))
((list? val) (map hs-strip-order-deep val))
(true val))))
(define (define
hs-method-call hs-method-call
(fn (fn
@@ -2696,6 +2765,8 @@
((store (host-get el "__hs_vars"))) ((store (host-get el "__hs_vars")))
(if (nil? store) nil (host-get store name))))) (if (nil? store) nil (host-get store name)))))
;; ── SourceInfo API ────────────────────────────────────────────────
(define (define
hs-dom-set-var-raw! hs-dom-set-var-raw!
(fn (fn
@@ -2728,8 +2799,6 @@
(if match (dom-parent match) nil))) (if match (dom-parent match) nil)))
(true el)))))) (true el))))))
;; ── SourceInfo API ────────────────────────────────────────────────
(define (define
hs-dom-walk hs-dom-walk
(fn (fn

View File

@@ -3724,9 +3724,25 @@
;; ── expressions/asExpression (42 tests) ── ;; ── expressions/asExpression (42 tests) ──
(defsuite "hs-upstream-expressions/asExpression" (defsuite "hs-upstream-expressions/asExpression"
(deftest "can accept custom conversions" (deftest "can accept custom conversions"
(error "SKIP (untranslated): can accept custom conversions")) (do
(hs-set-conversion! "Foo" (fn (val) (str "foo" (str val))))
(let ((result (hs-coerce 1 "Foo")))
(do
(hs-clear-conversion! "Foo")
(assert= result "foo1"))))
)
(deftest "can accept custom dynamic conversions" (deftest "can accept custom dynamic conversions"
(error "SKIP (untranslated): can accept custom dynamic conversions")) (do
(hs-add-dynamic-converter!
(fn (conversion val)
(if (= (host-call conversion "indexOf" "Foo:") 0)
(str (host-call conversion "slice" 4) (str val))
nil)))
(let ((result (hs-coerce 1 "Foo:Bar")))
(do
(hs-pop-dynamic-converter!)
(assert= result "Bar1"))))
)
(deftest "can use the a modifier if you like" (deftest "can use the a modifier if you like"
(let ((_result (eval-hs "1 as a Date"))) (let ((_result (eval-hs "1 as a Date")))
(assert= (host-call _result "getTime") 1)) (assert= (host-call _result "getTime") 1))

View File

@@ -326,6 +326,27 @@ MANUAL_TEST_BODIES = {
' (list (list (quote record) record)))', ' (list (list (quote record) record)))',
' "<div age=\\"21\\" style=\\"color:bleaux\\">John Connor</div>"))', ' "<div age=\\"21\\" style=\\"color:bleaux\\">John Connor</div>"))',
], ],
# asExpression: custom conversions — set/clear via hs-set-conversion! + hs-add-dynamic-converter!
"can accept custom conversions": [
' (do',
' (hs-set-conversion! "Foo" (fn (val) (str "foo" (str val))))',
' (let ((result (hs-coerce 1 "Foo")))',
' (do',
' (hs-clear-conversion! "Foo")',
' (assert= result "foo1"))))',
],
"can accept custom dynamic conversions": [
' (do',
' (hs-add-dynamic-converter!',
' (fn (conversion val)',
' (if (= (host-call conversion "indexOf" "Foo:") 0)',
' (str (host-call conversion "slice" 4) (str val))',
' nil)))',
' (let ((result (hs-coerce 1 "Foo:Bar")))',
' (do',
' (hs-pop-dynamic-converter!)',
' (assert= result "Bar1"))))',
],
# asExpression: Date/Set/Map need real JS host objects # asExpression: Date/Set/Map need real JS host objects
"converts value as Date": [ "converts value as Date": [
' (let ((_result (eval-hs "1 as Date")))', ' (let ((_result (eval-hs "1 as Date")))',