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

HS: fetch response unwrap + do-not-throw + dot-prop + JSON coerce (+19 tests)

Browse Source
This commit is contained in:
giles
2026-04-26 22:04:28 +00:00
parent cc800c3004
commit 2dadb6a521
7 changed files with 96 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
shared/static/wasm/sx/hs-compiler.sx
View File

@@ -1746,6 +1746,7 @@
(list? c)
(or
(= (first c) (quote hs-fetch))
(= (first c) (quote hs-fetch-no-throw))
(= (first c) (quote hs-wait))
(= (first c) (quote hs-wait-for))
(= (first c) (quote hs-wait-for-or))
@@ -1759,7 +1760,9 @@
(if
(and
(list? cmd)
(= (first cmd) (quote hs-fetch)))
(or
(= (first cmd) (quote hs-fetch))
(= (first cmd) (quote hs-fetch-no-throw))))
(list
(quote let)
(list (list (quote it) cmd))
@@ -1882,7 +1885,7 @@
(list (quote fn) (list) (hs-to-sx (nth ast 2)))))
((= head (quote fetch))
(list
(quote hs-fetch)
(if (nth ast 3) (quote hs-fetch-no-throw) (quote hs-fetch))
(hs-to-sx (nth ast 1))
(nth ast 2)))
((= head (quote fetch-gql))

8
shared/static/wasm/sx/hs-parser.sx
View File

@@ -438,6 +438,14 @@
((and (= (tp-type) "op") (= (tp-val) "'s"))
(do (adv!) (parse-poss-tail obj)))
((= (tp-type) "class") (parse-prop-chain obj))
((= (tp-type) "dot")
(do
(adv!)
(let ((typ2 (tp-type)) (val2 (tp-val)))
(if
(or (= typ2 "ident") (= typ2 "keyword"))
(do (adv!) (parse-poss (list (make-symbol ".") obj val2)))
obj))))
((= (tp-type) "paren-open")
(let
((args (parse-call-args)))

41
shared/static/wasm/sx/hs-runtime.sx
View File

@@ -888,14 +888,40 @@
out)))))))))))
(define
hs-fetch
hs-fetch-impl
(fn
(url format)
(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") (true format))))
((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
((raw (perform (list "io-fetch" url fmt))))
(cond ((= fmt "json") (hs-host-to-sx raw)) (true raw))))))
(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
@@ -986,9 +1012,10 @@
(true (str value))))
((= type-name "JSON")
(cond
((string? value) (guard (_e (true value)) (json-parse value)))
((dict? value) (hs-json-stringify value))
((list? value) (hs-json-stringify value))
((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