diff --git a/lib/hyperscript/runtime.sx b/lib/hyperscript/runtime.sx index 460f52cd..2fea1cd6 100644 --- a/lib/hyperscript/runtime.sx +++ b/lib/hyperscript/runtime.sx @@ -43,17 +43,7 @@ ;; 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)))) +(define meta (host-new "Object")) ;; ── Async / timing ────────────────────────────────────────────── @@ -61,11 +51,39 @@ ;; 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))) + _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) (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)))) + +;; 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 @@ -81,7 +99,7 @@ (host-call observer "observe" target) observer))))) -;; Wait for CSS transitions/animations to settle on an element. +;; Toggle between two classes — exactly one is active at a time. (define hs-on-mutation-attach! (fn @@ -102,16 +120,19 @@ (host-call observer "observe" target opts) observer)))))) -;; ── Class manipulation ────────────────────────────────────────── - -;; Toggle a single class on an element. -(define hs-init (fn (thunk) (thunk))) - -;; Toggle between two classes — exactly one is active at a time. -(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) - ;; 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 @@ -124,20 +145,15 @@ (target event-name timeout-ms) (perform (list (quote io-wait-event) target event-name timeout-ms))))) -;; ── DOM insertion ─────────────────────────────────────────────── - -;; Put content at a position relative to a target. -;; pos: "into" | "before" | "after" +;; Find next sibling matching a selector (or any sibling). (define hs-settle (fn (target) (perform (list (quote io-settle) target)))) -;; ── Navigation / traversal ────────────────────────────────────── - -;; Navigate to a URL. +;; Find previous sibling matching a selector. (define hs-toggle-class! (fn (target cls) (host-call (host-get target "classList") "toggle" cls))) -;; Find next sibling matching a selector (or any sibling). +;; First element matching selector within a scope. (define hs-toggle-between! (fn @@ -147,7 +163,7 @@ (do (dom-remove-class target cls1) (dom-add-class target cls2)) (do (dom-remove-class target cls2) (dom-add-class target cls1))))) -;; Find previous sibling matching a selector. +;; Last element matching selector. (define hs-toggle-style! (fn @@ -171,7 +187,7 @@ (dom-set-style target prop "hidden") (dom-set-style target prop ""))))))) -;; First element matching selector within a scope. +;; First/last within a specific scope. (define hs-toggle-style-between! (fn @@ -183,7 +199,6 @@ (dom-set-style target prop val2) (dom-set-style target prop val1))))) -;; Last element matching selector. (define hs-toggle-style-cycle! (fn @@ -204,7 +219,9 @@ (true (find-next (rest remaining)))))) (dom-set-style target prop (find-next vals))))) -;; First/last within a specific scope. +;; ── Iteration ─────────────────────────────────────────────────── + +;; Repeat a thunk N times. (define hs-take! (fn @@ -244,6 +261,7 @@ (dom-set-attr target name attr-val) (dom-set-attr target name "")))))))) +;; Repeat forever (until break — relies on exception/continuation). (begin (define hs-element? @@ -355,9 +373,10 @@ (dom-insert-adjacent-html target "beforeend" value) (hs-boot-subtree! target))))))))) -;; ── Iteration ─────────────────────────────────────────────────── +;; ── Fetch ─────────────────────────────────────────────────────── -;; Repeat a thunk N times. +;; Fetch a URL, parse response according to format. +;; (hs-fetch url format) — format is "json" | "text" | "html" (define hs-add-to! (fn @@ -370,7 +389,10 @@ (append target (list value)))) (true (do (host-call target "push" value) target))))) -;; Repeat forever (until break — relies on exception/continuation). +;; ── Type coercion ─────────────────────────────────────────────── + +;; Coerce a value to a type by name. +;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. (define hs-remove-from! (fn @@ -380,10 +402,10 @@ (filter (fn (x) (not (= x value))) target) (host-call target "splice" (host-call target "indexOf" value) 1)))) -;; ── Fetch ─────────────────────────────────────────────────────── +;; ── Object creation ───────────────────────────────────────────── -;; Fetch a URL, parse response according to format. -;; (hs-fetch url format) — format is "json" | "text" | "html" +;; Make a new object of a given type. +;; (hs-make type-name) — creates empty object/collection (define hs-splice-at! (fn @@ -407,10 +429,11 @@ (host-call target "splice" i 1)))) target)))) -;; ── Type coercion ─────────────────────────────────────────────── +;; ── Behavior installation ─────────────────────────────────────── -;; Coerce a value to a type by name. -;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. +;; 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-index (fn @@ -422,10 +445,10 @@ ((string? obj) (nth obj key)) (true (host-get obj key))))) -;; ── Object creation ───────────────────────────────────────────── +;; ── Measurement ───────────────────────────────────────────────── -;; Make a new object of a given type. -;; (hs-make type-name) — creates empty object/collection +;; Measure an element's bounding rect, store as local variables. +;; Returns a dict with x, y, width, height, top, left, right, bottom. (define hs-put-at! (fn @@ -447,11 +470,10 @@ ((= pos "start") (host-call target "unshift" value))) target))))))) -;; ── 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) +;; 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-dict-without (fn @@ -472,27 +494,19 @@ (host-call (host-global "Reflect") "deleteProperty" out key) out))))) -;; ── Measurement ───────────────────────────────────────────────── -;; Measure an element's bounding rect, store as local variables. -;; Returns a dict with x, y, width, height, top, left, right, bottom. +;; ── Transition ────────────────────────────────────────────────── + +;; Transition a CSS property to a value, optionally with duration. +;; (hs-transition target prop value duration) (define hs-set-on! (fn (props target) (for-each (fn (k) (host-set! target k (get props k))) (keys props)))) -;; 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-navigate! (fn (url) (perform (list (quote io-navigate) url)))) - -;; ── Transition ────────────────────────────────────────────────── - -;; Transition a CSS property to a value, optionally with duration. -;; (hs-transition target prop value duration) (define hs-ask (fn @@ -631,6 +645,10 @@ (true (find-next (dom-next-sibling el)))))) (find-next sibling))))) + + + + (define hs-previous (fn @@ -653,11 +671,8 @@ (define hs-query-all (fn (sel) (host-call (dom-body) "querySelectorAll" sel))) - - - - - +;; ── Sandbox/test runtime additions ────────────────────────────── +;; Property access — dot notation and .length (define hs-query-all-in (fn @@ -666,22 +681,23 @@ (nil? target) (hs-query-all sel) (host-call target "querySelectorAll" sel)))) - +;; DOM query stub — sandbox returns empty list (define hs-list-set (fn (lst idx val) (append (take lst idx) (cons val (drop lst (+ idx 1)))))) -;; ── Sandbox/test runtime additions ────────────────────────────── -;; Property access — dot notation and .length +;; Method dispatch — obj.method(args) (define hs-to-number (fn (v) (if (number? v) v (or (parse-number (str v)) 0)))) -;; DOM query stub — sandbox returns empty list + +;; ── 0.9.90 features ───────────────────────────────────────────── +;; beep! — debug logging, returns value unchanged (define hs-query-first (fn (sel) (host-call (host-global "document") "querySelector" sel))) -;; Method dispatch — obj.method(args) +;; Property-based is — check obj.key truthiness (define hs-query-last (fn @@ -689,11 +705,9 @@ (let ((all (dom-query-all (dom-body) sel))) (if (> (len all) 0) (nth all (- (len all) 1)) nil)))) - -;; ── 0.9.90 features ───────────────────────────────────────────── -;; beep! — debug logging, returns value unchanged +;; Array slicing (inclusive both ends) (define hs-first (fn (scope sel) (dom-query-all scope sel))) -;; Property-based is — check obj.key truthiness +;; Collection: sorted by (define hs-last (fn @@ -701,7 +715,7 @@ (let ((all (dom-query-all scope sel))) (if (> (len all) 0) (nth all (- (len all) 1)) nil)))) -;; Array slicing (inclusive both ends) +;; Collection: sorted by descending (define hs-repeat-times (fn @@ -719,7 +733,7 @@ ((= signal "hs-continue") (do-repeat (+ i 1))) (true (do-repeat (+ i 1)))))))) (do-repeat 0))) -;; Collection: sorted by +;; Collection: split by (define hs-repeat-forever (fn @@ -735,7 +749,7 @@ ((= signal "hs-continue") (do-forever)) (true (do-forever)))))) (do-forever))) -;; Collection: sorted by descending +;; Collection: joined by (define hs-repeat-while (fn @@ -748,7 +762,7 @@ ((= signal "hs-break") nil) ((= signal "hs-continue") (hs-repeat-while cond-fn thunk)) (true (hs-repeat-while cond-fn thunk))))))) -;; Collection: split by + (define hs-repeat-until (fn @@ -760,7 +774,7 @@ ((= signal "hs-continue") (if (cond-fn) nil (hs-repeat-until cond-fn thunk))) (true (if (cond-fn) nil (hs-repeat-until cond-fn thunk))))))) -;; Collection: joined by + (define hs-for-each (fn @@ -2511,6 +2525,8 @@ ((nth entry 2) val))) _hs-dom-watchers))) +;; ── SourceInfo API ──────────────────────────────────────────────── + (define hs-dom-is-ancestor? (fn @@ -2526,8 +2542,6 @@ (fn-name args) (let ((fn (host-global fn-name))) (if fn (host-call-fn fn args) nil)))) -;; ── SourceInfo API ──────────────────────────────────────────────── - (define hs-source-for (fn @@ -2543,16 +2557,9 @@ (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-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 (fn (src-str) (hs-source-for (hs-parse-ast src-str)))) (define hs-src-at @@ -2562,7 +2569,8 @@ walk (fn (node keys) - (if (or (nil? keys) (= (len keys) 0)) + (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)))) @@ -2575,7 +2583,8 @@ walk (fn (node keys) - (if (or (nil? keys) (= (len keys) 0)) + (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)))) diff --git a/shared/static/wasm/sx/hs-runtime.sx b/shared/static/wasm/sx/hs-runtime.sx index 460f52cd..962841b7 100644 --- a/shared/static/wasm/sx/hs-runtime.sx +++ b/shared/static/wasm/sx/hs-runtime.sx @@ -43,12 +43,26 @@ ;; Run an initializer function immediately. ;; (hs-init thunk) — called at element boot time +(define meta (host-new "Object")) + +(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))) + (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))))) + ((wrapped (fn (event) (do (host-set! meta "caller" _hs-on-caller) (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)))) diff --git a/shared/static/wasm/sx_browser.bc.js b/shared/static/wasm/sx_browser.bc.js index f3ee5606..e68ba512 100644 --- a/shared/static/wasm/sx_browser.bc.js +++ b/shared/static/wasm/sx_browser.bc.js @@ -46045,7 +46045,7 @@ d2=133,bi=102,bh="Re__Hash_set",cA="Stdlib__Type",cB=114,fF="Stdlib__Buffer",dX= } return trampoline(eval_expr(Sx_types[75].call(null, mac), local)); } - var step_limit = [0, 0], step_count = [0, 0]; + var step_limit = [0, 0], step_count = [0, 0], _wc_check = 0; function cek_step_loop(state$0){ var state = state$0; for(;;){ @@ -46055,6 +46055,11 @@ d2=133,bi=102,bh="Re__Hash_set",cA="Stdlib__Type",cB=114,fF="Stdlib__Buffer",dX= throw caml_maybe_attach_backtrace ([0, Sx_types[9], "TIMEOUT: step limit exceeded"], 1); } + if(++_wc_check >= 10000){ _wc_check = 0; + if(globalThis.__hs_deadline && Date.now() > globalThis.__hs_deadline) + throw caml_maybe_attach_backtrace + ([0, Sx_types[9], "TIMEOUT: wall clock exceeded"], 1); + } var or = cek_terminal_p(state), or$0 = Sx_types[56].call(null, or) ? or : cek_suspended_p(state); diff --git a/tests/hs-run-filtered.js b/tests/hs-run-filtered.js index 8a1406a0..79abbba7 100755 --- a/tests/hs-run-filtered.js +++ b/tests/hs-run-filtered.js @@ -574,8 +574,8 @@ function _mockFetch(url) { return { ok: route.status < 400, status: route.status || 200, url: url || '/test', _body: route.body || '', _json: route.json || route.body || '', _html: route.html || route.body || '' }; } -globalThis._driveAsync=function driveAsync(r,d){d=d||0;if(d>500||!r||!r.suspended)return;if(_testDeadline && Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');const req=r.request;const items=req&&(req.items||req);const op=items&&items[0];const opName=typeof op==='string'?op:(op&&op.name)||String(op); - function doResume(v){try{const x=r.resume(v);driveAsync(x,d+1);}catch(e){}} +globalThis._driveAsync=function driveAsync(r,d){d=d||0;if(_testDeadline && Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');if(d>500||!r||!r.suspended)return;const req=r.request;const items=req&&(req.items||req);const op=items&&items[0];const opName=typeof op==='string'?op:(op&&op.name)||String(op); + function doResume(v){try{const x=r.resume(v);driveAsync(x,d+1);}catch(e){const msg=e&&(e.message||(Array.isArray(e)&&typeof e[2]==='string'&&e[2])||'');if(String(msg).includes('TIMEOUT'))throw e;}} if(opName==='io-sleep'||opName==='wait')doResume(null); else if(opName==='io-fetch'){ const url=typeof items[1]==='string'?items[1]:'/test'; @@ -684,9 +684,25 @@ for(let i=startTest;i 5000)process.stdout.write(` SLOW: test ${i} took ${elapsed}ms [${suite}] ${name}\n`); if(!ok && err && err.includes('TIMEOUT'))process.stdout.write(` TIMEOUT: test ${i} [${suite}] ${name}\n`);