coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix callable? type mismatch, restore 20 HS test regressions, add host-* server stubs

Browse Source 
callable? in boot-helpers.sx checked for "native-fn" but type-of returns
"function" for NativeFn — broke make-spread and all native fn dispatch
in aser. Restore 20 behavioral tests replaced with NOT IMPLEMENTED stubs
by the test regeneration commit. Add host-* platform primitive stubs to
sx_server.ml so boot-helpers.sx loads without errors server-side.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-16 22:15:55 +00:00
parent 76f7e3b68a
commit 8c85e892c2
8 changed files with 2427 additions and 1975 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
hosts/ocaml/bin/sx_server.ml
View File

@@ -368,6 +368,9 @@ let cek_run_with_io state =
loop () loop ()
(** IO-aware eval_expr — like eval_expr but handles IO suspension. *) (** IO-aware eval_expr — like eval_expr but handles IO suspension. *)
(* IO-aware eval — used by site_mode. The regular file loading path
uses Sx_ref.eval_expr which delegates IO suspension to the
_cek_io_suspend_hook → _vm_suspension_to_dict chain. *)
let _eval_expr_io expr env = let _eval_expr_io expr env =
let state = Sx_ref.make_cek_state expr env (List []) in let state = Sx_ref.make_cek_state expr env (List []) in
cek_run_with_io state cek_run_with_io state

220
shared/static/wasm/sx/boot-helpers.sx
View File

@@ -2,34 +2,104 @@
(import (sx browser)) (import (sx browser))
(import (web adapter-dom)) (import (web adapter-dom))
(define-library (web boot-helpers) (define-library
(export _sx-bound-prefix mark-processed! is-processed? clear-processed! callable? to-kebab sx-load-components call-expr base-env get-render-env merge-envs sx-render-with-env parse-env-attr store-env-attr resolve-mount-target remove-head-element set-sx-comp-cookie clear-sx-comp-cookie log-parse-error loaded-component-names csrf-token validate-for-request build-request-body abort-previous-target abort-previous track-controller track-controller-target new-abort-controller abort-signal apply-optimistic revert-optimistic dom-has-attr? show-indicator disable-elements clear-loading-state abort-error? promise-catch fetch-request fetch-location fetch-and-restore fetch-preload fetch-streaming dom-parse-html-document dom-body-inner-html create-script-clone cross-origin? browser-scroll-to with-transition event-source-connect event-source-listen bind-boost-link bind-boost-form bind-client-route-click sw-post-message try-parse-json strip-component-scripts extract-response-css sx-render sx-hydrate sx-process-scripts select-from-container children-to-fragment select-html-from-doc register-io-deps resolve-page-data parse-sx-data try-eval-content try-async-eval-content try-rerender-page execute-action bind-preload persist-offline-data retrieve-offline-data) (web boot-helpers)
(export
_sx-bound-prefix
mark-processed!
is-processed?
clear-processed!
callable?
to-kebab
sx-load-components
call-expr
base-env
get-render-env
merge-envs
sx-render-with-env
parse-env-attr
store-env-attr
resolve-mount-target
remove-head-element
set-sx-comp-cookie
clear-sx-comp-cookie
log-parse-error
loaded-component-names
csrf-token
validate-for-request
build-request-body
abort-previous-target
abort-previous
track-controller
track-controller-target
new-abort-controller
abort-signal
apply-optimistic
revert-optimistic
dom-has-attr?
show-indicator
disable-elements
clear-loading-state
abort-error?
promise-catch
fetch-request
fetch-location
fetch-and-restore
fetch-preload
fetch-streaming
dom-parse-html-document
dom-body-inner-html
create-script-clone
cross-origin?
browser-scroll-to
with-transition
event-source-connect
event-source-listen
bind-boost-link
bind-boost-form
bind-client-route-click
sw-post-message
try-parse-json
strip-component-scripts
extract-response-css
sx-render
sx-hydrate
sx-process-scripts
select-from-container
children-to-fragment
select-html-from-doc
register-io-deps
resolve-page-data
parse-sx-data
try-eval-content
try-async-eval-content
try-rerender-page
execute-action
bind-preload
persist-offline-data
retrieve-offline-data)
(begin (begin
(define _sx-bound-prefix "_sxBound") (define _sx-bound-prefix "_sxBound")
(define (define
mark-processed! mark-processed!
(fn (el key) (host-set! el (str _sx-bound-prefix key) true))) (fn (el key) (host-set! el (str _sx-bound-prefix key) true)))
(define (define
is-processed? is-processed?
(fn (fn
(el key) (el key)
(let ((v (host-get el (str _sx-bound-prefix key)))) (if v true false)))) (let
((v (host-get el (str _sx-bound-prefix key))))
(if v true false))))
(define (define
clear-processed! clear-processed!
(fn (el key) (host-set! el (str _sx-bound-prefix key) nil))) (fn (el key) (host-set! el (str _sx-bound-prefix key) nil)))
(define (define
callable? callable?
(fn (fn
(v) (v)
(let (let
((t (type-of v))) ((t (type-of v)))
(or (= t "lambda") (= t "native-fn") (= t "continuation"))))) (or (= t "lambda") (= t "function") (= t "continuation")))))
(define (define
to-kebab to-kebab
(fn (fn
@@ -52,7 +122,6 @@
(append! result ch)) (append! result ch))
(loop (+ i 1))))) (loop (+ i 1)))))
(join "" result)))) (join "" result))))
(define (define
sx-load-components sx-load-components
(fn (fn
@@ -63,7 +132,6 @@
(let (let
((exprs (sx-parse text))) ((exprs (sx-parse text)))
(for-each (fn (expr) (cek-eval expr)) exprs))))) (for-each (fn (expr) (cek-eval expr)) exprs)))))
(define (define
call-expr call-expr
(fn (fn
@@ -72,11 +140,9 @@
(let (let
((exprs (sx-parse expr-text))) ((exprs (sx-parse expr-text)))
(when (not (empty? exprs)) (cek-eval (first exprs)))))) (when (not (empty? exprs)) (cek-eval (first exprs))))))
(define (define
base-env base-env
(fn () "Return the current global environment." (global-env))) (fn () "Return the current global environment." (global-env)))
(define (define
get-render-env get-render-env
(fn (fn
@@ -85,14 +151,12 @@
(let (let
((env (base-env))) ((env (base-env)))
(if (and extra (not (nil? extra))) (env-merge env extra) env)))) (if (and extra (not (nil? extra))) (env-merge env extra) env))))
(define (define
merge-envs merge-envs
(fn (fn
(a b) (a b)
"Merge two environments." "Merge two environments."
(if (and a b) (env-merge a b) (or a b (global-env))))) (if (and a b) (env-merge a b) (or a b (global-env)))))
(define (define
sx-render-with-env sx-render-with-env
(fn (fn
@@ -115,35 +179,31 @@
(host-call frag "appendChild" (host-get temp "content")))))) (host-call frag "appendChild" (host-get temp "content"))))))
exprs) exprs)
frag))) frag)))
(define (define
parse-env-attr parse-env-attr
(fn (el) "Parse data-sx-env attribute (JSON key-value pairs)." nil)) (fn (el) "Parse data-sx-env attribute (JSON key-value pairs)." nil))
(define store-env-attr (fn (el base new-env) nil)) (define store-env-attr (fn (el base new-env) nil))
(define (define
resolve-mount-target resolve-mount-target
(fn (fn
(target) (target)
"Resolve a CSS selector string to a DOM element." "Resolve a CSS selector string to a DOM element."
(if (string? target) (dom-query target) target))) (if (string? target) (dom-query target) target)))
(define (define
remove-head-element remove-head-element
(fn (fn
(sel) (sel)
"Remove a <head> element matching selector." "Remove a <head> element matching selector."
(let ((el (dom-query sel))) (when el (dom-remove el))))) (let ((el (dom-query sel))) (when el (dom-remove el)))))
(define
(define set-sx-comp-cookie (fn (hash) (set-cookie "sx-components" hash))) set-sx-comp-cookie
(fn (hash) (set-cookie "sx-components" hash)))
(define clear-sx-comp-cookie (fn () (set-cookie "sx-components" ""))) (define clear-sx-comp-cookie (fn () (set-cookie "sx-components" "")))
(define (define
log-parse-error log-parse-error
(fn (label text err) (log-error (str "Parse error in " label ": " err)))) (fn
(label text err)
(log-error (str "Parse error in " label ": " err))))
(define (define
loaded-component-names loaded-component-names
(fn (fn
@@ -167,7 +227,6 @@
(split text ","))))) (split text ",")))))
scripts) scripts)
names))) names)))
(define (define
csrf-token csrf-token
(fn (fn
@@ -175,9 +234,7 @@
(let (let
((meta (dom-query "meta[name=\"csrf-token\"]"))) ((meta (dom-query "meta[name=\"csrf-token\"]")))
(if meta (dom-get-attr meta "content") nil)))) (if meta (dom-get-attr meta "content") nil))))
(define validate-for-request (fn (el) true)) (define validate-for-request (fn (el) true))
(define (define
build-request-body build-request-body
(fn (fn
@@ -223,25 +280,15 @@
"content-type" "content-type"
"application/x-www-form-urlencoded")))) "application/x-www-form-urlencoded"))))
(dict "url" url "body" nil "content-type" nil)))))) (dict "url" url "body" nil "content-type" nil))))))
(define abort-previous-target (fn (el) nil)) (define abort-previous-target (fn (el) nil))
(define abort-previous (fn (el) nil)) (define abort-previous (fn (el) nil))
(define track-controller (fn (el ctrl) nil)) (define track-controller (fn (el ctrl) nil))
(define track-controller-target (fn (el ctrl) nil)) (define track-controller-target (fn (el ctrl) nil))
(define new-abort-controller (fn () (host-new "AbortController"))) (define new-abort-controller (fn () (host-new "AbortController")))
(define abort-signal (fn (ctrl) (host-get ctrl "signal"))) (define abort-signal (fn (ctrl) (host-get ctrl "signal")))
(define apply-optimistic (fn (el) nil)) (define apply-optimistic (fn (el) nil))
(define revert-optimistic (fn (el) nil)) (define revert-optimistic (fn (el) nil))
(define dom-has-attr? (fn (el name) (host-call el "hasAttribute" name))) (define dom-has-attr? (fn (el name) (host-call el "hasAttribute" name)))
(define (define
show-indicator show-indicator
(fn (fn
@@ -257,7 +304,6 @@
(dom-remove-class indicator "hidden") (dom-remove-class indicator "hidden")
(dom-add-class indicator "sx-indicator-visible")))) (dom-add-class indicator "sx-indicator-visible"))))
indicator-sel))) indicator-sel)))
(define (define
disable-elements disable-elements
(fn (fn
@@ -271,7 +317,6 @@
(for-each (fn (e) (dom-set-attr e "disabled" "")) elts) (for-each (fn (e) (dom-set-attr e "disabled" "")) elts)
elts) elts)
(list))))) (list)))))
(define (define
clear-loading-state clear-loading-state
(fn (fn
@@ -289,13 +334,10 @@
(when (when
disabled-elts disabled-elts
(for-each (fn (e) (dom-remove-attr e "disabled")) disabled-elts)))) (for-each (fn (e) (dom-remove-attr e "disabled")) disabled-elts))))
(define abort-error? (fn (err) (= (host-get err "name") "AbortError"))) (define abort-error? (fn (err) (= (host-get err "name") "AbortError")))
(define (define
promise-catch promise-catch
(fn (p f) (let ((cb (host-callback f))) (host-call p "catch" cb)))) (fn (p f) (let ((cb (host-callback f))) (host-call p "catch" cb))))
(define (define
fetch-request fetch-request
(fn (fn
@@ -335,7 +377,6 @@
(fn (text) (success-fn ok status get-header text)) (fn (text) (success-fn ok status get-header text))
error-fn))) error-fn)))
error-fn)))))) error-fn))))))
(define (define
fetch-location fetch-location
(fn (fn
@@ -343,13 +384,22 @@
(let (let
((target (or (dom-query "[sx-boost]") (dom-query "#main-panel")))) ((target (or (dom-query "[sx-boost]") (dom-query "#main-panel"))))
(when target (browser-navigate url))))) (when target (browser-navigate url)))))
(define (define
fetch-and-restore fetch-and-restore
(fn (fn
(main url headers scroll-y) (main url headers scroll-y)
(fetch-request (fetch-request
(dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil) (dict
"url"
url
"method"
"GET"
"headers"
headers
"body"
nil
"signal"
nil)
(fn (fn
(resp-ok status get-header text) (resp-ok status get-header text)
(when (when
@@ -360,7 +410,8 @@
(contains? ct "text/html") (contains? ct "text/html")
(let (let
((parser (host-new "DOMParser")) ((parser (host-new "DOMParser"))
(doc (host-call parser "parseFromString" text "text/html")) (doc
(host-call parser "parseFromString" text "text/html"))
(content (host-call doc "querySelector" "#sx-content"))) (content (host-call doc "querySelector" "#sx-content")))
(if (if
content content
@@ -402,24 +453,31 @@
(post-swap main) (post-swap main)
(host-call (dom-window) "scrollTo" 0 scroll-y))) (host-call (dom-window) "scrollTo" 0 scroll-y)))
(fn (err) (log-warn (str "fetch-and-restore error: " err)))))) (fn (err) (log-warn (str "fetch-and-restore error: " err))))))
(define (define
fetch-preload fetch-preload
(fn (fn
(url headers cache) (url headers cache)
(fetch-request (fetch-request
(dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil) (dict
"url"
url
"method"
"GET"
"headers"
headers
"body"
nil
"signal"
nil)
(fn (fn
(resp-ok status get-header text) (resp-ok status get-header text)
(when resp-ok (preload-cache-set cache url text))) (when resp-ok (preload-cache-set cache url text)))
(fn (err) nil)))) (fn (err) nil))))
(define (define
fetch-streaming fetch-streaming
(fn (fn
(target pathname headers swap-fn) (target pathname headers swap-fn)
(fetch-and-restore target pathname headers 0))) (fetch-and-restore target pathname headers 0)))
(define (define
dom-parse-html-document dom-parse-html-document
(fn (fn
@@ -427,11 +485,9 @@
(let (let
((parser (host-new "DOMParser"))) ((parser (host-new "DOMParser")))
(host-call parser "parseFromString" text "text/html")))) (host-call parser "parseFromString" text "text/html"))))
(define (define
dom-body-inner-html dom-body-inner-html
(fn (doc) (host-get (host-get doc "body") "innerHTML"))) (fn (doc) (host-get (host-get doc "body") "innerHTML")))
(define (define
create-script-clone create-script-clone
(fn (fn
@@ -456,7 +512,6 @@
(loop (+ i 1)))))) (loop (+ i 1))))))
(host-set! live "textContent" (host-get dead "textContent")) (host-set! live "textContent" (host-get dead "textContent"))
live))) live)))
(define (define
cross-origin? cross-origin?
(fn (fn
@@ -465,23 +520,22 @@
(or (starts-with? url "http://") (starts-with? url "https://")) (or (starts-with? url "http://") (starts-with? url "https://"))
(not (starts-with? url (browser-location-origin))) (not (starts-with? url (browser-location-origin)))
false))) false)))
(define (define
browser-scroll-to browser-scroll-to
(fn (x y) (host-call (dom-window) "scrollTo" x y))) (fn (x y) (host-call (dom-window) "scrollTo" x y)))
(define (define
with-transition with-transition
(fn (fn
(enabled thunk) (enabled thunk)
(if (if
(and enabled (host-get (host-global "document") "startViewTransition")) (and
enabled
(host-get (host-global "document") "startViewTransition"))
(host-call (host-call
(host-global "document") (host-global "document")
"startViewTransition" "startViewTransition"
(host-callback thunk)) (host-callback thunk))
(thunk)))) (thunk))))
(define (define
event-source-connect event-source-connect
(fn (fn
@@ -490,7 +544,6 @@
((source (host-new "EventSource" url))) ((source (host-new "EventSource" url)))
(host-set! source "_sxElement" el) (host-set! source "_sxElement" el)
source))) source)))
(define (define
event-source-listen event-source-listen
(fn (fn
@@ -500,7 +553,6 @@
"addEventListener" "addEventListener"
event-name event-name
(host-callback (fn (e) (handler e)))))) (host-callback (fn (e) (handler e))))))
(define (define
bind-boost-link bind-boost-link
(fn (fn
@@ -520,7 +572,6 @@
(not (dom-has-attr? el "sx-push-url")) (not (dom-has-attr? el "sx-push-url"))
(dom-set-attr el "sx-push-url" "true")) (dom-set-attr el "sx-push-url" "true"))
(execute-request el nil nil)))))) (execute-request el nil nil))))))
(define (define
bind-boost-form bind-boost-form
(fn (fn
@@ -529,7 +580,6 @@
form form
"submit" "submit"
(fn (e) (prevent-default e) (execute-request form nil nil))))) (fn (e) (prevent-default e) (execute-request form nil nil)))))
(define (define
bind-client-route-click bind-client-route-click
(fn (fn
@@ -549,7 +599,10 @@
boost-el boost-el
(let (let
((attr (dom-get-attr boost-el "sx-boost"))) ((attr (dom-get-attr boost-el "sx-boost")))
(if (and attr (not (= attr "true"))) attr "#sx-content")) (if
(and attr (not (= attr "true")))
attr
"#sx-content"))
"#sx-content"))) "#sx-content")))
(if (if
(try-client-route (url-pathname href) target-sel) (try-client-route (url-pathname href) target-sel)
@@ -564,11 +617,8 @@
(dom-set-attr link "sx-select" target-sel) (dom-set-attr link "sx-select" target-sel)
(dom-set-attr link "sx-push-url" "true") (dom-set-attr link "sx-push-url" "true")
(execute-request link nil nil))))))))) (execute-request link nil nil)))))))))
(define sw-post-message (fn (msg) nil)) (define sw-post-message (fn (msg) nil))
(define try-parse-json (fn (text) (json-parse text))) (define try-parse-json (fn (text) (json-parse text)))
(define (define
strip-component-scripts strip-component-scripts
(fn (fn
@@ -596,17 +646,19 @@
(let (let
((comp-text (slice rest-str 0 end-offset)) ((comp-text (slice rest-str 0 end-offset))
(before (slice s 0 start-idx)) (before (slice s 0 start-idx))
(after (slice rest-str (+ end-offset (len end-tag))))) (after
(slice rest-str (+ end-offset (len end-tag)))))
(sx-load-components comp-text) (sx-load-components comp-text)
(loop (str before after))))))))) (loop (str before after)))))))))
result))) result)))
(define (define
extract-response-css extract-response-css
(fn (fn
(text) (text)
(let (let
((result text) (start-tag "<style data-sx-css>") (end-tag "</style>")) ((result text)
(start-tag "<style data-sx-css>")
(end-tag "</style>"))
(let (let
loop loop
((s result)) ((s result))
@@ -625,7 +677,8 @@
(let (let
((css-text (slice rest-str 0 end-offset)) ((css-text (slice rest-str 0 end-offset))
(before (slice s 0 start-idx)) (before (slice s 0 start-idx))
(after (slice rest-str (+ end-offset (len end-tag))))) (after
(slice rest-str (+ end-offset (len end-tag)))))
(let (let
((doc (host-global "document")) ((doc (host-global "document"))
(style-el (host-call doc "createElement" "style"))) (style-el (host-call doc "createElement" "style")))
@@ -633,7 +686,6 @@
(dom-append-to-head style-el)) (dom-append-to-head style-el))
(loop (str before after))))))))) (loop (str before after)))))))))
result))) result)))
(define (define
sx-render sx-render
(fn (fn
@@ -652,9 +704,9 @@
exprs) exprs)
(scope-pop! "sx-render-markers") (scope-pop! "sx-render-markers")
frag))) frag)))
(define
(define sx-hydrate (fn (root) (sx-hydrate-elements (or root (dom-body))))) sx-hydrate
(fn (root) (sx-hydrate-elements (or root (dom-body)))))
(define (define
sx-process-scripts sx-process-scripts
(fn (fn
@@ -683,7 +735,6 @@
(log-error (str "sx-process-scripts: " err))))) (log-error (str "sx-process-scripts: " err)))))
exprs)))))) exprs))))))
scripts)))) scripts))))
(define (define
select-from-container select-from-container
(fn (fn
@@ -697,7 +748,6 @@
(children-to-fragment selected) (children-to-fragment selected)
(children-to-fragment container))) (children-to-fragment container)))
(children-to-fragment container)))) (children-to-fragment container))))
(define (define
children-to-fragment children-to-fragment
(fn (fn
@@ -712,7 +762,6 @@
((child (dom-first-child el))) ((child (dom-first-child el)))
(when child (dom-append frag child) (loop)))) (when child (dom-append frag child) (loop))))
frag))) frag)))
(define (define
select-html-from-doc select-html-from-doc
(fn (fn
@@ -723,11 +772,8 @@
((el (dom-query doc selector))) ((el (dom-query doc selector)))
(if el (dom-inner-html el) (dom-body-inner-html doc))) (if el (dom-inner-html el) (dom-body-inner-html doc)))
(dom-body-inner-html doc)))) (dom-body-inner-html doc))))
(define register-io-deps (fn (deps) nil)) (define register-io-deps (fn (deps) nil))
(define resolve-page-data (fn (page-name params callback) nil)) (define resolve-page-data (fn (page-name params callback) nil))
(define (define
parse-sx-data parse-sx-data
(fn (fn
@@ -738,7 +784,6 @@
((exprs (sx-parse text))) ((exprs (sx-parse text)))
(if (not (empty? exprs)) (first exprs) nil)) (if (not (empty? exprs)) (first exprs) nil))
nil))) nil)))
(define (define
try-eval-content try-eval-content
(fn (fn
@@ -758,23 +803,14 @@
(when result (dom-append frag result)))) (when result (dom-append frag result))))
exprs) exprs)
frag))))) frag)))))
(define (define
try-async-eval-content try-async-eval-content
(fn (content-src env callback) (try-eval-content content-src env))) (fn (content-src env callback) (try-eval-content content-src env)))
(define try-rerender-page (fn () nil)) (define try-rerender-page (fn () nil))
(define execute-action (fn () nil)) (define execute-action (fn () nil))
(define bind-preload (fn () nil)) (define bind-preload (fn () nil))
(define persist-offline-data (fn () nil)) (define persist-offline-data (fn () nil))
(define retrieve-offline-data (fn () nil))))
(define retrieve-offline-data (fn () nil))
))
;; Re-export to global env ;; Re-export to global env
(import (web boot-helpers)) (import (web boot-helpers))

4
shared/static/wasm/sx/boot-helpers.sxbc
View File

File diff suppressed because one or more lines are too long

4
shared/static/wasm/sx/hs-compiler.sxbc
View File

File diff suppressed because one or more lines are too long

37
shared/static/wasm/sx_browser.bc.js
View File

File diff suppressed because one or more lines are too long

2
shared/static/wasm/sx_browser.bc.wasm.js
View File

@@ -1792,7 +1792,7 @@
blake2_js_for_wasm_create: blake2_js_for_wasm_create}; blake2_js_for_wasm_create: blake2_js_for_wasm_create};
} }
(globalThis)) (globalThis))
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-da652b03",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-def18509",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var ({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-875d5bae",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-def18509",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var
c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new
Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new
Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new

1250
spec/tests/test-hyperscript-behavioral.sx
View File

File diff suppressed because it is too large Load Diff

220
web/lib/boot-helpers.sx
View File

@@ -2,34 +2,104 @@
(import (sx browser)) (import (sx browser))
(import (web adapter-dom)) (import (web adapter-dom))
(define-library (web boot-helpers) (define-library
(export _sx-bound-prefix mark-processed! is-processed? clear-processed! callable? to-kebab sx-load-components call-expr base-env get-render-env merge-envs sx-render-with-env parse-env-attr store-env-attr resolve-mount-target remove-head-element set-sx-comp-cookie clear-sx-comp-cookie log-parse-error loaded-component-names csrf-token validate-for-request build-request-body abort-previous-target abort-previous track-controller track-controller-target new-abort-controller abort-signal apply-optimistic revert-optimistic dom-has-attr? show-indicator disable-elements clear-loading-state abort-error? promise-catch fetch-request fetch-location fetch-and-restore fetch-preload fetch-streaming dom-parse-html-document dom-body-inner-html create-script-clone cross-origin? browser-scroll-to with-transition event-source-connect event-source-listen bind-boost-link bind-boost-form bind-client-route-click sw-post-message try-parse-json strip-component-scripts extract-response-css sx-render sx-hydrate sx-process-scripts select-from-container children-to-fragment select-html-from-doc register-io-deps resolve-page-data parse-sx-data try-eval-content try-async-eval-content try-rerender-page execute-action bind-preload persist-offline-data retrieve-offline-data) (web boot-helpers)
(export
_sx-bound-prefix
mark-processed!
is-processed?
clear-processed!
callable?
to-kebab
sx-load-components
call-expr
base-env
get-render-env
merge-envs
sx-render-with-env
parse-env-attr
store-env-attr
resolve-mount-target
remove-head-element
set-sx-comp-cookie
clear-sx-comp-cookie
log-parse-error
loaded-component-names
csrf-token
validate-for-request
build-request-body
abort-previous-target
abort-previous
track-controller
track-controller-target
new-abort-controller
abort-signal
apply-optimistic
revert-optimistic
dom-has-attr?
show-indicator
disable-elements
clear-loading-state
abort-error?
promise-catch
fetch-request
fetch-location
fetch-and-restore
fetch-preload
fetch-streaming
dom-parse-html-document
dom-body-inner-html
create-script-clone
cross-origin?
browser-scroll-to
with-transition
event-source-connect
event-source-listen
bind-boost-link
bind-boost-form
bind-client-route-click
sw-post-message
try-parse-json
strip-component-scripts
extract-response-css
sx-render
sx-hydrate
sx-process-scripts
select-from-container
children-to-fragment
select-html-from-doc
register-io-deps
resolve-page-data
parse-sx-data
try-eval-content
try-async-eval-content
try-rerender-page
execute-action
bind-preload
persist-offline-data
retrieve-offline-data)
(begin (begin
(define _sx-bound-prefix "_sxBound") (define _sx-bound-prefix "_sxBound")
(define (define
mark-processed! mark-processed!
(fn (el key) (host-set! el (str _sx-bound-prefix key) true))) (fn (el key) (host-set! el (str _sx-bound-prefix key) true)))
(define (define
is-processed? is-processed?
(fn (fn
(el key) (el key)
(let ((v (host-get el (str _sx-bound-prefix key)))) (if v true false)))) (let
((v (host-get el (str _sx-bound-prefix key))))
(if v true false))))
(define (define
clear-processed! clear-processed!
(fn (el key) (host-set! el (str _sx-bound-prefix key) nil))) (fn (el key) (host-set! el (str _sx-bound-prefix key) nil)))
(define (define
callable? callable?
(fn (fn
(v) (v)
(let (let
((t (type-of v))) ((t (type-of v)))
(or (= t "lambda") (= t "native-fn") (= t "continuation"))))) (or (= t "lambda") (= t "function") (= t "continuation")))))
(define (define
to-kebab to-kebab
(fn (fn
@@ -52,7 +122,6 @@
(append! result ch)) (append! result ch))
(loop (+ i 1))))) (loop (+ i 1)))))
(join "" result)))) (join "" result))))
(define (define
sx-load-components sx-load-components
(fn (fn
@@ -63,7 +132,6 @@
(let (let
((exprs (sx-parse text))) ((exprs (sx-parse text)))
(for-each (fn (expr) (cek-eval expr)) exprs))))) (for-each (fn (expr) (cek-eval expr)) exprs)))))
(define (define
call-expr call-expr
(fn (fn
@@ -72,11 +140,9 @@
(let (let
((exprs (sx-parse expr-text))) ((exprs (sx-parse expr-text)))
(when (not (empty? exprs)) (cek-eval (first exprs)))))) (when (not (empty? exprs)) (cek-eval (first exprs))))))
(define (define
base-env base-env
(fn () "Return the current global environment." (global-env))) (fn () "Return the current global environment." (global-env)))
(define (define
get-render-env get-render-env
(fn (fn
@@ -85,14 +151,12 @@
(let (let
((env (base-env))) ((env (base-env)))
(if (and extra (not (nil? extra))) (env-merge env extra) env)))) (if (and extra (not (nil? extra))) (env-merge env extra) env))))
(define (define
merge-envs merge-envs
(fn (fn
(a b) (a b)
"Merge two environments." "Merge two environments."
(if (and a b) (env-merge a b) (or a b (global-env))))) (if (and a b) (env-merge a b) (or a b (global-env)))))
(define (define
sx-render-with-env sx-render-with-env
(fn (fn
@@ -115,35 +179,31 @@
(host-call frag "appendChild" (host-get temp "content")))))) (host-call frag "appendChild" (host-get temp "content"))))))
exprs) exprs)
frag))) frag)))
(define (define
parse-env-attr parse-env-attr
(fn (el) "Parse data-sx-env attribute (JSON key-value pairs)." nil)) (fn (el) "Parse data-sx-env attribute (JSON key-value pairs)." nil))
(define store-env-attr (fn (el base new-env) nil)) (define store-env-attr (fn (el base new-env) nil))
(define (define
resolve-mount-target resolve-mount-target
(fn (fn
(target) (target)
"Resolve a CSS selector string to a DOM element." "Resolve a CSS selector string to a DOM element."
(if (string? target) (dom-query target) target))) (if (string? target) (dom-query target) target)))
(define (define
remove-head-element remove-head-element
(fn (fn
(sel) (sel)
"Remove a <head> element matching selector." "Remove a <head> element matching selector."
(let ((el (dom-query sel))) (when el (dom-remove el))))) (let ((el (dom-query sel))) (when el (dom-remove el)))))
(define
(define set-sx-comp-cookie (fn (hash) (set-cookie "sx-components" hash))) set-sx-comp-cookie
(fn (hash) (set-cookie "sx-components" hash)))
(define clear-sx-comp-cookie (fn () (set-cookie "sx-components" ""))) (define clear-sx-comp-cookie (fn () (set-cookie "sx-components" "")))
(define (define
log-parse-error log-parse-error
(fn (label text err) (log-error (str "Parse error in " label ": " err)))) (fn
(label text err)
(log-error (str "Parse error in " label ": " err))))
(define (define
loaded-component-names loaded-component-names
(fn (fn
@@ -167,7 +227,6 @@
(split text ","))))) (split text ",")))))
scripts) scripts)
names))) names)))
(define (define
csrf-token csrf-token
(fn (fn
@@ -175,9 +234,7 @@
(let (let
((meta (dom-query "meta[name=\"csrf-token\"]"))) ((meta (dom-query "meta[name=\"csrf-token\"]")))
(if meta (dom-get-attr meta "content") nil)))) (if meta (dom-get-attr meta "content") nil))))
(define validate-for-request (fn (el) true)) (define validate-for-request (fn (el) true))
(define (define
build-request-body build-request-body
(fn (fn
@@ -223,25 +280,15 @@
"content-type" "content-type"
"application/x-www-form-urlencoded")))) "application/x-www-form-urlencoded"))))
(dict "url" url "body" nil "content-type" nil)))))) (dict "url" url "body" nil "content-type" nil))))))
(define abort-previous-target (fn (el) nil)) (define abort-previous-target (fn (el) nil))
(define abort-previous (fn (el) nil)) (define abort-previous (fn (el) nil))
(define track-controller (fn (el ctrl) nil)) (define track-controller (fn (el ctrl) nil))
(define track-controller-target (fn (el ctrl) nil)) (define track-controller-target (fn (el ctrl) nil))
(define new-abort-controller (fn () (host-new "AbortController"))) (define new-abort-controller (fn () (host-new "AbortController")))
(define abort-signal (fn (ctrl) (host-get ctrl "signal"))) (define abort-signal (fn (ctrl) (host-get ctrl "signal")))
(define apply-optimistic (fn (el) nil)) (define apply-optimistic (fn (el) nil))
(define revert-optimistic (fn (el) nil)) (define revert-optimistic (fn (el) nil))
(define dom-has-attr? (fn (el name) (host-call el "hasAttribute" name))) (define dom-has-attr? (fn (el name) (host-call el "hasAttribute" name)))
(define (define
show-indicator show-indicator
(fn (fn
@@ -257,7 +304,6 @@
(dom-remove-class indicator "hidden") (dom-remove-class indicator "hidden")
(dom-add-class indicator "sx-indicator-visible")))) (dom-add-class indicator "sx-indicator-visible"))))
indicator-sel))) indicator-sel)))
(define (define
disable-elements disable-elements
(fn (fn
@@ -271,7 +317,6 @@
(for-each (fn (e) (dom-set-attr e "disabled" "")) elts) (for-each (fn (e) (dom-set-attr e "disabled" "")) elts)
elts) elts)
(list))))) (list)))))
(define (define
clear-loading-state clear-loading-state
(fn (fn
@@ -289,13 +334,10 @@
(when (when
disabled-elts disabled-elts
(for-each (fn (e) (dom-remove-attr e "disabled")) disabled-elts)))) (for-each (fn (e) (dom-remove-attr e "disabled")) disabled-elts))))
(define abort-error? (fn (err) (= (host-get err "name") "AbortError"))) (define abort-error? (fn (err) (= (host-get err "name") "AbortError")))
(define (define
promise-catch promise-catch
(fn (p f) (let ((cb (host-callback f))) (host-call p "catch" cb)))) (fn (p f) (let ((cb (host-callback f))) (host-call p "catch" cb))))
(define (define
fetch-request fetch-request
(fn (fn
@@ -335,7 +377,6 @@
(fn (text) (success-fn ok status get-header text)) (fn (text) (success-fn ok status get-header text))
error-fn))) error-fn)))
error-fn)))))) error-fn))))))
(define (define
fetch-location fetch-location
(fn (fn
@@ -343,13 +384,22 @@
(let (let
((target (or (dom-query "[sx-boost]") (dom-query "#main-panel")))) ((target (or (dom-query "[sx-boost]") (dom-query "#main-panel"))))
(when target (browser-navigate url))))) (when target (browser-navigate url)))))
(define (define
fetch-and-restore fetch-and-restore
(fn (fn
(main url headers scroll-y) (main url headers scroll-y)
(fetch-request (fetch-request
(dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil) (dict
"url"
url
"method"
"GET"
"headers"
headers
"body"
nil
"signal"
nil)
(fn (fn
(resp-ok status get-header text) (resp-ok status get-header text)
(when (when
@@ -360,7 +410,8 @@
(contains? ct "text/html") (contains? ct "text/html")
(let (let
((parser (host-new "DOMParser")) ((parser (host-new "DOMParser"))
(doc (host-call parser "parseFromString" text "text/html")) (doc
(host-call parser "parseFromString" text "text/html"))
(content (host-call doc "querySelector" "#sx-content"))) (content (host-call doc "querySelector" "#sx-content")))
(if (if
content content
@@ -402,24 +453,31 @@
(post-swap main) (post-swap main)
(host-call (dom-window) "scrollTo" 0 scroll-y))) (host-call (dom-window) "scrollTo" 0 scroll-y)))
(fn (err) (log-warn (str "fetch-and-restore error: " err)))))) (fn (err) (log-warn (str "fetch-and-restore error: " err))))))
(define (define
fetch-preload fetch-preload
(fn (fn
(url headers cache) (url headers cache)
(fetch-request (fetch-request
(dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil) (dict
"url"
url
"method"
"GET"
"headers"
headers
"body"
nil
"signal"
nil)
(fn (fn
(resp-ok status get-header text) (resp-ok status get-header text)
(when resp-ok (preload-cache-set cache url text))) (when resp-ok (preload-cache-set cache url text)))
(fn (err) nil)))) (fn (err) nil))))
(define (define
fetch-streaming fetch-streaming
(fn (fn
(target pathname headers swap-fn) (target pathname headers swap-fn)
(fetch-and-restore target pathname headers 0))) (fetch-and-restore target pathname headers 0)))
(define (define
dom-parse-html-document dom-parse-html-document
(fn (fn
@@ -427,11 +485,9 @@
(let (let
((parser (host-new "DOMParser"))) ((parser (host-new "DOMParser")))
(host-call parser "parseFromString" text "text/html")))) (host-call parser "parseFromString" text "text/html"))))
(define (define
dom-body-inner-html dom-body-inner-html
(fn (doc) (host-get (host-get doc "body") "innerHTML"))) (fn (doc) (host-get (host-get doc "body") "innerHTML")))
(define (define
create-script-clone create-script-clone
(fn (fn
@@ -456,7 +512,6 @@
(loop (+ i 1)))))) (loop (+ i 1))))))
(host-set! live "textContent" (host-get dead "textContent")) (host-set! live "textContent" (host-get dead "textContent"))
live))) live)))
(define (define
cross-origin? cross-origin?
(fn (fn
@@ -465,23 +520,22 @@
(or (starts-with? url "http://") (starts-with? url "https://")) (or (starts-with? url "http://") (starts-with? url "https://"))
(not (starts-with? url (browser-location-origin))) (not (starts-with? url (browser-location-origin)))
false))) false)))
(define (define
browser-scroll-to browser-scroll-to
(fn (x y) (host-call (dom-window) "scrollTo" x y))) (fn (x y) (host-call (dom-window) "scrollTo" x y)))
(define (define
with-transition with-transition
(fn (fn
(enabled thunk) (enabled thunk)
(if (if
(and enabled (host-get (host-global "document") "startViewTransition")) (and
enabled
(host-get (host-global "document") "startViewTransition"))
(host-call (host-call
(host-global "document") (host-global "document")
"startViewTransition" "startViewTransition"
(host-callback thunk)) (host-callback thunk))
(thunk)))) (thunk))))
(define (define
event-source-connect event-source-connect
(fn (fn
@@ -490,7 +544,6 @@
((source (host-new "EventSource" url))) ((source (host-new "EventSource" url)))
(host-set! source "_sxElement" el) (host-set! source "_sxElement" el)
source))) source)))
(define (define
event-source-listen event-source-listen
(fn (fn
@@ -500,7 +553,6 @@
"addEventListener" "addEventListener"
event-name event-name
(host-callback (fn (e) (handler e)))))) (host-callback (fn (e) (handler e))))))
(define (define
bind-boost-link bind-boost-link
(fn (fn
@@ -520,7 +572,6 @@
(not (dom-has-attr? el "sx-push-url")) (not (dom-has-attr? el "sx-push-url"))
(dom-set-attr el "sx-push-url" "true")) (dom-set-attr el "sx-push-url" "true"))
(execute-request el nil nil)))))) (execute-request el nil nil))))))
(define (define
bind-boost-form bind-boost-form
(fn (fn
@@ -529,7 +580,6 @@
form form
"submit" "submit"
(fn (e) (prevent-default e) (execute-request form nil nil))))) (fn (e) (prevent-default e) (execute-request form nil nil)))))
(define (define
bind-client-route-click bind-client-route-click
(fn (fn
@@ -549,7 +599,10 @@
boost-el boost-el
(let (let
((attr (dom-get-attr boost-el "sx-boost"))) ((attr (dom-get-attr boost-el "sx-boost")))
(if (and attr (not (= attr "true"))) attr "#sx-content")) (if
(and attr (not (= attr "true")))
attr
"#sx-content"))
"#sx-content"))) "#sx-content")))
(if (if
(try-client-route (url-pathname href) target-sel) (try-client-route (url-pathname href) target-sel)
@@ -564,11 +617,8 @@
(dom-set-attr link "sx-select" target-sel) (dom-set-attr link "sx-select" target-sel)
(dom-set-attr link "sx-push-url" "true") (dom-set-attr link "sx-push-url" "true")
(execute-request link nil nil))))))))) (execute-request link nil nil)))))))))
(define sw-post-message (fn (msg) nil)) (define sw-post-message (fn (msg) nil))
(define try-parse-json (fn (text) (json-parse text))) (define try-parse-json (fn (text) (json-parse text)))
(define (define
strip-component-scripts strip-component-scripts
(fn (fn
@@ -596,17 +646,19 @@
(let (let
((comp-text (slice rest-str 0 end-offset)) ((comp-text (slice rest-str 0 end-offset))
(before (slice s 0 start-idx)) (before (slice s 0 start-idx))
(after (slice rest-str (+ end-offset (len end-tag))))) (after
(slice rest-str (+ end-offset (len end-tag)))))
(sx-load-components comp-text) (sx-load-components comp-text)
(loop (str before after))))))))) (loop (str before after)))))))))
result))) result)))
(define (define
extract-response-css extract-response-css
(fn (fn
(text) (text)
(let (let
((result text) (start-tag "<style data-sx-css>") (end-tag "</style>")) ((result text)
(start-tag "<style data-sx-css>")
(end-tag "</style>"))
(let (let
loop loop
((s result)) ((s result))
@@ -625,7 +677,8 @@
(let (let
((css-text (slice rest-str 0 end-offset)) ((css-text (slice rest-str 0 end-offset))
(before (slice s 0 start-idx)) (before (slice s 0 start-idx))
(after (slice rest-str (+ end-offset (len end-tag))))) (after
(slice rest-str (+ end-offset (len end-tag)))))
(let (let
((doc (host-global "document")) ((doc (host-global "document"))
(style-el (host-call doc "createElement" "style"))) (style-el (host-call doc "createElement" "style")))
@@ -633,7 +686,6 @@
(dom-append-to-head style-el)) (dom-append-to-head style-el))
(loop (str before after))))))))) (loop (str before after)))))))))
result))) result)))
(define (define
sx-render sx-render
(fn (fn
@@ -652,9 +704,9 @@
exprs) exprs)
(scope-pop! "sx-render-markers") (scope-pop! "sx-render-markers")
frag))) frag)))
(define
(define sx-hydrate (fn (root) (sx-hydrate-elements (or root (dom-body))))) sx-hydrate
(fn (root) (sx-hydrate-elements (or root (dom-body)))))
(define (define
sx-process-scripts sx-process-scripts
(fn (fn
@@ -683,7 +735,6 @@
(log-error (str "sx-process-scripts: " err))))) (log-error (str "sx-process-scripts: " err)))))
exprs)))))) exprs))))))
scripts)))) scripts))))
(define (define
select-from-container select-from-container
(fn (fn
@@ -697,7 +748,6 @@
(children-to-fragment selected) (children-to-fragment selected)
(children-to-fragment container))) (children-to-fragment container)))
(children-to-fragment container)))) (children-to-fragment container))))
(define (define
children-to-fragment children-to-fragment
(fn (fn
@@ -712,7 +762,6 @@
((child (dom-first-child el))) ((child (dom-first-child el)))
(when child (dom-append frag child) (loop)))) (when child (dom-append frag child) (loop))))
frag))) frag)))
(define (define
select-html-from-doc select-html-from-doc
(fn (fn
@@ -723,11 +772,8 @@
((el (dom-query doc selector))) ((el (dom-query doc selector)))
(if el (dom-inner-html el) (dom-body-inner-html doc))) (if el (dom-inner-html el) (dom-body-inner-html doc)))
(dom-body-inner-html doc)))) (dom-body-inner-html doc))))
(define register-io-deps (fn (deps) nil)) (define register-io-deps (fn (deps) nil))
(define resolve-page-data (fn (page-name params callback) nil)) (define resolve-page-data (fn (page-name params callback) nil))
(define (define
parse-sx-data parse-sx-data
(fn (fn
@@ -738,7 +784,6 @@
((exprs (sx-parse text))) ((exprs (sx-parse text)))
(if (not (empty? exprs)) (first exprs) nil)) (if (not (empty? exprs)) (first exprs) nil))
nil))) nil)))
(define (define
try-eval-content try-eval-content
(fn (fn
@@ -758,23 +803,14 @@
(when result (dom-append frag result)))) (when result (dom-append frag result))))
exprs) exprs)
frag))))) frag)))))
(define (define
try-async-eval-content try-async-eval-content
(fn (content-src env callback) (try-eval-content content-src env))) (fn (content-src env callback) (try-eval-content content-src env)))
(define try-rerender-page (fn () nil)) (define try-rerender-page (fn () nil))
(define execute-action (fn () nil)) (define execute-action (fn () nil))
(define bind-preload (fn () nil)) (define bind-preload (fn () nil))
(define persist-offline-data (fn () nil)) (define persist-offline-data (fn () nil))
(define retrieve-offline-data (fn () nil))))
(define retrieve-offline-data (fn () nil))
))
;; Re-export to global env ;; Re-export to global env
(import (web boot-helpers)) (import (web boot-helpers))