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

IO registry: defio declares platform suspension points

Browse Source 
Core SX has zero IO — platforms extend __io-registry via (defio name
:category :data/:code/:effect ...). The server web platform declares 44
operations in web/io.sx. batchable_helpers now derived from registry
(:batchable true) instead of hardcoded list. Startup validation warns if
bound IO ops lack registry entries. Browser gets empty registry, ready
for step 5 (IO suspension).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-02 23:21:48 +00:00
parent 17b6c872f2
commit ede05c26f5
16 changed files with 486 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
hosts/ocaml/bin/run_tests.ml
View File

@@ -608,6 +608,25 @@ let make_test_env () =
island
| _ -> Nil)));
(* defio — IO registry for platform suspension points *)
let io_registry = Hashtbl.create 64 in
ignore (Sx_types.env_bind env "__io-registry" (Dict io_registry));
ignore (Sx_ref.register_special_form (String "defio") (NativeFn ("defio", fun sf_args ->
let raw_args = match sf_args with
| [List a; Env _] | [ListRef { contents = a }; Env _] -> a
| _ -> [] in
match raw_args with
| String name :: rest ->
let entry = Hashtbl.create 8 in
let rec parse = function
| Keyword k :: v :: rest -> Hashtbl.replace entry k v; parse rest
| _ -> () in
parse rest;
Hashtbl.replace entry "name" (String name);
Hashtbl.replace io_registry name (Dict entry);
Dict entry
| _ -> Nil)));
(* --- Primitives for canonical.sx / content tests --- *)
bind "contains-char?" (fun args ->
match args with

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

@@ -1948,7 +1948,27 @@ let http_setup_declarative_stubs env =
noop "defquery";
noop "defaction";
noop "defrelation";
noop "defstyle"
noop "defstyle";
(* IO registry — starts empty, platforms extend via defio.
defio is a special form that populates __io-registry with metadata
about suspension points (IO ops that require platform resolution). *)
let io_registry = Hashtbl.create 64 in
ignore (env_bind env "__io-registry" (Dict io_registry));
ignore (Sx_ref.register_special_form (String "defio") (NativeFn ("defio", fun sf_args ->
let raw_args = match sf_args with
| [List a; Env _] | [ListRef { contents = a }; Env _] -> a
| _ -> [] in
match raw_args with
| String name :: rest ->
let entry = Hashtbl.create 8 in
let rec parse = function
| Keyword k :: v :: rest -> Hashtbl.replace entry k v; parse rest
| _ -> () in
parse rest;
Hashtbl.replace entry "name" (String name);
Hashtbl.replace io_registry name (Dict entry);
Dict entry
| _ -> Nil)))
let http_setup_platform_constructors env =
(* Platform constructor functions expected by evaluator.sx.
@@ -2365,6 +2385,7 @@ let http_mode port =
spec_base ^ "/signals.sx";
lib_base ^ "/compiler.sx";
web_base ^ "/adapter-html.sx"; web_base ^ "/adapter-sx.sx";
web_base ^ "/io.sx";
web_base ^ "/web-forms.sx"; web_base ^ "/engine.sx";
web_base ^ "/request-handler.sx";
web_base ^ "/page-helpers.sx";
@@ -2404,11 +2425,35 @@ let http_mode port =
load_dir sx_sx;
let t1 = Unix.gettimeofday () in
Printf.eprintf "[sx-http] All files loaded in %.3fs\n%!" (t1 -. t0);
(* Derive batchable_helpers from __io-registry *)
(try match env_get env "__io-registry" with
| Dict registry ->
let batchable = Hashtbl.fold (fun name entry acc ->
match entry with
| Dict d -> (match Hashtbl.find_opt d "batchable" with
| Some (Bool true) -> name :: acc | _ -> acc)
| _ -> acc) registry [] in
if batchable <> [] then batchable_helpers := batchable;
Printf.eprintf "[sx-http] IO registry: %d ops, %d batchable\n%!"
(Hashtbl.length registry) (List.length batchable);
(* Validate: warn if bound IO ops are not declared *)
let expected = ["query"; "action"; "request-arg"; "request-method";
"ctx"; "helper"; "json-encode"; "into"; "sleep";
"set-response-status"; "set-response-header"] in
List.iter (fun name ->
if not (Hashtbl.mem registry name) then
Printf.eprintf "[sx-http] WARNING: IO '%s' bound but not in registry\n%!" name
) expected
| _ -> ()
with _ -> ());
(* Extract app config from __app-config dict *)
(try match env_get env "__app-config" with
| Dict d ->
_app_config := Some d;
batchable_helpers := get_app_list "batchable-helpers" ["highlight"; "component-source"];
(* App config can add extra batchable helpers on top of registry *)
let extra = get_app_list "batchable-helpers" [] in
if extra <> [] then
batchable_helpers := List.sort_uniq String.compare (!batchable_helpers @ extra);
Printf.eprintf "[sx-http] App config loaded: title=%s prefix=%s\n%!"
(get_app_str "title" "?") (get_app_str "path-prefix" "?")
| _ -> Printf.eprintf "[sx-http] WARNING: __app-config is not a dict\n%!"

21
hosts/ocaml/browser/sx_browser.ml
View File

@@ -671,6 +671,27 @@ let () =
bind "define-page-helper" (fun _ -> Nil);
(* IO registry — starts empty in browser. Platforms extend via defio.
Browser has zero suspension points initially; future browser IO
(lazy module loads, fetch-request) will add entries here. *)
let io_registry = Hashtbl.create 16 in
ignore (env_bind global_env "__io-registry" (Dict io_registry));
ignore (Sx_ref.register_special_form (String "defio") (NativeFn ("defio", fun sf_args ->
let raw_args = match sf_args with
| [List a; Env _] | [ListRef { contents = a }; Env _] -> a
| _ -> [] in
match raw_args with
| String name :: rest ->
let entry = Hashtbl.create 8 in
let rec parse = function
| Keyword k :: v :: rest -> Hashtbl.replace entry k v; parse rest
| _ -> () in
parse rest;
Hashtbl.replace entry "name" (String name);
Hashtbl.replace io_registry name (Dict entry);
Dict entry
| _ -> Nil)));
(* --- Render --- *)
Sx_render.setup_render_env global_env;
bind "set-render-active!" (fun _ -> Nil);

2
shared/static/wasm/sx/boot.sx
View File

@@ -425,7 +425,6 @@
()
(do
(log-info (str "sx-browser " SX_VERSION))
(init-css-tracking)
(process-page-scripts)
(process-sx-scripts nil)
(sx-hydrate-elements nil)
@@ -433,7 +432,6 @@
(run-post-render-hooks)
(flush-collected-styles)
(set-timeout (fn () (process-elements nil)) 0)
(dom-listen (dom-window) "popstate" (fn (e) (handle-popstate 0)))
(dom-set-attr
(host-get (dom-document) "documentElement")
"data-sx-ready"

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

File diff suppressed because one or more lines are too long

5
shared/static/wasm/sx/engine.sx
View File

@@ -117,7 +117,7 @@
build-request-headers
:effects (io)
(fn
(el (loaded-components :as list) (css-hash :as string))
(el (loaded-components :as list))
(let
((headers (dict "SX-Request" "true" "SX-Current-URL" (browser-location-href))))
(let
@@ -126,7 +126,6 @@
(let
((comp-hash (dom-get-attr (dom-query "script[data-components][data-hash]") "data-hash")))
(when comp-hash (dict-set! headers "SX-Components-Hash" comp-hash)))
(when css-hash (dict-set! headers "SX-Css" css-hash))
(let
((extra-h (dom-get-attr el "sx-headers")))
(when
@@ -162,8 +161,6 @@
(get-header "SX-Location")
"replace-url"
(get-header "SX-Replace-Url")
"css-hash"
(get-header "SX-Css-Hash")
"trigger-swap"
(get-header "SX-Trigger-After-Swap")
"trigger-settle"

4
shared/static/wasm/sx/engine.sxbc
View File

File diff suppressed because one or more lines are too long

47
shared/static/wasm/sx/orchestration.sx
View File

@@ -1,7 +1,5 @@
(define _preload-cache (dict))
(define _css-hash "")
(define
dispatch-trigger-events
:effects (mutation io)
@@ -26,19 +24,6 @@
(dom-dispatch el trimmed (dict)))))
(split header-val ",")))))))
(define
init-css-tracking
:effects (mutation io)
(fn
()
(let
((meta (dom-query "meta[name=\"sx-css-classes\"]")))
(when
meta
(let
((content (dom-get-attr meta "content")))
(when content (set! _css-hash content)))))))
(define
execute-request
:effects (mutation io)
@@ -115,8 +100,7 @@
(final-url (get body-info "url"))
(body (get body-info "body"))
(ct (get body-info "content-type"))
(headers
(build-request-headers el (loaded-component-names) _css-hash))
(headers (build-request-headers el (loaded-component-names)))
(csrf (csrf-token)))
(when
extraParams
@@ -214,9 +198,6 @@
(text :as string))
(let
((resp-headers (process-response-headers get-header)))
(let
((new-hash (get resp-headers "css-hash")))
(when new-hash (set! _css-hash new-hash)))
(dispatch-trigger-events el (get resp-headers "trigger"))
(process-cache-directives el resp-headers text)
(cond
@@ -1144,8 +1125,7 @@
pathname
(build-request-headers
target
(loaded-component-names)
_css-hash))
(loaded-component-names)))
true)
(if
(get match "has-data")
@@ -1181,8 +1161,7 @@
pathname
(build-request-headers
target
(loaded-component-names)
_css-hash)
(loaded-component-names))
0))
(swap-rendered-content
target
@@ -1240,8 +1219,7 @@
pathname
(build-request-headers
target
(loaded-component-names)
_css-hash)
(loaded-component-names))
0))
(swap-rendered-content
target
@@ -1262,8 +1240,7 @@
pathname
(build-request-headers
target
(loaded-component-names)
_css-hash)
(loaded-component-names))
0))
(swap-rendered-content
target
@@ -1293,8 +1270,7 @@
pathname
(build-request-headers
target
(loaded-component-names)
_css-hash)
(loaded-component-names))
0))
(swap-rendered-content
target
@@ -1471,10 +1447,7 @@
info
(do-preload
(get info "url")
(build-request-headers
el
(loaded-component-names)
_css-hash)))))))))))
(build-request-headers el (loaded-component-names))))))))))))
(define
do-preload
@@ -1592,8 +1565,4 @@
:effects (mutation io)
(fn
()
(do
(init-css-tracking)
(sx-process-scripts nil)
(sx-hydrate nil)
(process-elements nil))))
(do (sx-process-scripts nil) (sx-hydrate nil) (process-elements nil))))

4
shared/static/wasm/sx/orchestration.sxbc
View File

File diff suppressed because one or more lines are too long

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

File diff suppressed because one or more lines are too long

BIN
shared/static/wasm/sx_browser.bc.wasm.assets/dune__exe__Sx_browser-9ecd0d53.wasm → shared/static/wasm/sx_browser.bc.wasm.assets/dune__exe__Sx_browser-2ca913af.wasm
View File

Binary file not shown.

2
shared/static/wasm/sx_browser.bc.wasm.assets/dune__exe__Sx_browser-9ecd0d53.wasm.map → shared/static/wasm/sx_browser.bc.wasm.assets/dune__exe__Sx_browser-2ca913af.wasm.map
View File

File diff suppressed because one or more lines are too long

BIN
shared/static/wasm/sx_browser.bc.wasm.assets/sx-319ce79b.wasm
View File

Binary file not shown.

1
shared/static/wasm/sx_browser.bc.wasm.assets/sx-319ce79b.wasm.map
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};
}
(globalThis))
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["sx-de8114db",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-9ecd0d53",[2,3,5]],["std_exit-10fb8830",[2]],["start-80fdb768",0]],"generated":(b=>{var
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["sx-de8114db",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-2ca913af",[2,3,5]],["std_exit-10fb8830",[2]],["start-80fdb768",0]],"generated":(b=>{var
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_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new

318
web/io.sx Normal file
View File

@@ -0,0 +1,318 @@
(defio
"query"
:category :data
:params (service name &rest kwargs)
:returns "any"
:doc "Fetch data from another service.")
(defio
"action"
:category :effect
:params (service name &rest kwargs)
:returns "any"
:doc "Execute a mutation on another service.")
(defio
"helper"
:category :data
:params (name &rest args)
:returns "any"
:doc "Call a page helper function.")
(defio
"frag"
:category :data
:params (service type &rest kwargs)
:returns "string"
:doc "Fetch HTML fragment from another service.")
(defio
"service"
:category :data
:params (service-or-method &rest args)
:returns "any"
:doc "Call a domain service method.")
(defio
"request-arg"
:category :data
:params (name &optional default)
:returns "any"
:doc "Read a URL query parameter.")
(defio
"request-method"
:category :data
:params ()
:returns "string"
:doc "Current HTTP method.")
(defio
"request-path"
:category :data
:params ()
:returns "string"
:doc "Current request path.")
(defio
"request-form"
:category :data
:params (name &optional default)
:returns "any"
:doc "Read a form field.")
(defio
"request-json"
:category :data
:params ()
:returns "dict?"
:doc "Read JSON body.")
(defio
"request-header"
:category :data
:params (name &optional default)
:returns "string?"
:doc "Read a request header.")
(defio
"request-content-type"
:category :data
:params ()
:returns "string?"
:doc "Content-Type of current request.")
(defio
"request-args-all"
:category :data
:params ()
:returns "dict"
:doc "All query parameters as dict.")
(defio
"request-form-all"
:category :data
:params ()
:returns "dict"
:doc "All form fields as dict.")
(defio
"request-form-list"
:category :data
:params (field)
:returns "list"
:doc "Multi-value form field.")
(defio
"request-headers-all"
:category :data
:params ()
:returns "dict"
:doc "All request headers as dict.")
(defio
"request-file-name"
:category :data
:params (field)
:returns "string?"
:doc "Uploaded file name by field.")
(defio
"request-view-args"
:category :data
:params (key)
:returns "any"
:doc "URL path parameter.")
(defio
"ctx"
:category :data
:params (key)
:returns "any"
:doc "Read from render context.")
(defio
"current-user"
:category :data
:params ()
:returns "dict?"
:doc "Current authenticated user.")
(defio
"htmx-request?"
:category :data
:params ()
:returns "boolean"
:doc "Is this an HTMX request?")
(defio
"csrf-token"
:category :data
:params ()
:returns "string"
:doc "Current CSRF token.")
(defio
"app-rights"
:category :data
:params ()
:returns "dict"
:doc "Current user's rights.")
(defio
"nav-tree"
:category :data
:params ()
:returns "list"
:cacheable true
:doc "Navigation structure.")
(defio
"get-children"
:category :data
:params (&rest kwargs)
:returns "list"
:doc "Child entities.")
(defio
"relations-from"
:category :data
:params (entity-type)
:returns "list"
:cacheable true
:doc "Relation definitions for entity type.")
(defio
"config"
:category :data
:params (key)
:returns "any"
:cacheable true
:doc "Read from host configuration.")
(defio
"jinja-global"
:category :data
:params (key &optional default)
:returns "any"
:doc "Read a Jinja global.")
(defio
"url-for"
:category :data
:params (endpoint &rest kwargs)
:returns "string"
:doc "Generate URL for endpoint.")
(defio
"route-prefix"
:category :data
:params ()
:returns "string"
:doc "Service URL prefix.")
(defio
"app-url"
:category :data
:params (service &optional path)
:returns "string"
:cacheable true
:doc "Full URL for a service.")
(defio
"asset-url"
:category :data
:params (&rest path)
:returns "string"
:cacheable true
:doc "Versioned static asset URL.")
(defio
"set-response-status"
:category :effect
:params (status)
:returns "nil"
:doc "Set HTTP response status code.")
(defio
"set-response-header"
:category :effect
:params (name value)
:returns "nil"
:doc "Set HTTP response header.")
(defio
"abort"
:category :effect
:params (status &optional message)
:returns "nil"
:doc "Raise HTTP error.")
(defio
"state-get"
:category :data
:params (key &optional default)
:returns "any"
:doc "Read ephemeral per-process state.")
(defio
"state-set!"
:category :effect
:params (key value)
:returns "nil"
:doc "Write ephemeral per-process state.")
(defio
"now"
:category :data
:params (&optional fmt)
:returns "string"
:doc "Current timestamp.")
(defio
"sleep"
:category :effect
:params (ms)
:returns "nil"
:doc "Pause execution.")
(defio
"g"
:category :data
:params (key)
:returns "any"
:doc "Read from Quart g object.")
(defio
"json-encode"
:category :code
:params (&rest values)
:returns "string"
:cacheable true
:doc "JSON-serialize values.")
(defio
"into"
:category :code
:params (&rest args)
:returns "any"
:cacheable true
:doc "Template composition.")
(defio
"highlight"
:category :code
:params (code &optional lang)
:returns "sx-source"
:batchable true
:cacheable true
:doc "Syntax-highlight code.")
(defio
"component-source"
:category :code
:params (name)
:returns "string"
:batchable true
:cacheable true
:doc "Pretty-printed component source.")