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

Step 3: IO registry — spec-level defio + io contract dispatch

Browse Source 
Promotes defio from native OCaml special form to spec-level CEK
evaluator feature. The IO registry is now the contract layer between
evaluator and platform.

Evaluator additions (spec/evaluator.sx):
- *io-registry* mutable dict global (like *library-registry*)
- io-register!, io-registered?, io-lookup, io-names accessors
- defio-parse-kwargs! recursive keyword parser
- sf-defio processes (defio "name" :category :data :params (...) ...)
- "defio" dispatch in step-eval-list
- step-sf-io: the contract function — validates against registry,
  then delegates to perform for IO suspension
- "io" dispatch in step-eval-list

Native OCaml defio handlers removed from:
- sx_server.ml (~20 lines)
- sx_browser.ml (~20 lines)
- run_tests.ml (~18 lines)
All replaced with __io-registry alias to spec's *io-registry*.

IO accessor functions bound in run_tests.ml env so tests can
call io-registered?, io-lookup, io-names.

10 new tests (spec/tests/test-io-registry.sx):
- defio populates registry
- io-lookup returns spec with name/category/returns/doc
- io-registered?/io-names work correctly
- kwargs parsing (batchable, cacheable, params)
- io contract rejects unregistered ops
- io contract passes validation for registered ops

2608/2608 tests passing (+10 new).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-03 21:18:04 +00:00
parent b6f304e91a
commit 5f72801901
7 changed files with 256 additions and 120 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -610,24 +610,13 @@ 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)));
(* IO registry — spec-level defio populates *io-registry* in evaluator.
Bind accessor functions + __io-registry alias for backward compat. *)
ignore (Sx_types.env_bind env "__io-registry" Sx_ref._io_registry_);
bind "io-registered?" (fun args -> match args with [String n] -> Sx_ref.io_registered_p (String n) | _ -> Bool false);
bind "io-lookup" (fun args -> match args with [String n] -> Sx_ref.io_lookup (String n) | _ -> Nil);
bind "io-names" (fun _args -> Sx_ref.io_names ());
bind "io-register!" (fun args -> match args with [String n; spec] -> Sx_ref.io_register_b (String n) spec | _ -> Nil);
(* --- Primitives for canonical.sx / content tests --- *)
bind "contains-char?" (fun args ->

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

@@ -2007,26 +2007,9 @@ let http_setup_declarative_stubs env =
noop "defaction";
noop "defrelation";
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)))
(* IO registry — spec-level defio populates *io-registry* in evaluator.
Alias as __io-registry for backward compat. *)
ignore (env_bind env "__io-registry" Sx_ref._io_registry_)
let http_setup_platform_constructors env =
(* Platform constructor functions expected by evaluator.sx.

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

@@ -670,26 +670,9 @@ 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)));
(* IO registry — spec-level defio populates *io-registry* in evaluator.
Alias as __io-registry for backward compat. *)
ignore (env_bind global_env "__io-registry" Sx_ref._io_registry_);
(* --- Render --- *)
Sx_render.setup_render_env global_env;

34
hosts/ocaml/lib/sx_ref.ml
View File

File diff suppressed because one or more lines are too long

1
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -159,6 +159,7 @@ let take a b = _prim "take" [a; b]
let drop a b = _prim "drop" [a; b]
(* Predicates *)
let keyword_p a = _prim "keyword?" [a]
let empty_p a = _prim "empty?" [a]
let number_p a = _prim "number?" [a]
let string_p a = _prim "string?" [a]

169
spec/evaluator.sx
View File

@@ -391,6 +391,30 @@
(spec exports)
(dict-set! *library-registry* (library-name-key spec) {:exports exports})))
(define *io-registry* (dict))
;; Cond/case helpers
(define io-register! (fn (name spec) (dict-set! *io-registry* name spec)))
(define io-registered? (fn (name) (has-key? *io-registry* name)))
;; Special form constructors — build state for CEK evaluation
(define io-lookup (fn (name) (get *io-registry* name)))
(define io-names (fn () (keys *io-registry*)))
(define
step-sf-io
(fn
(args env kont)
(let
((name (first args)) (io-args (rest args)))
(when
(not (io-registered? name))
(error
(str "io: unknown operation '" name "' — not in *io-registry*")))
(make-cek-state (cons (quote perform) (list {:args io-args :op name})) env kont))))
(define
trampoline
(fn
@@ -403,16 +427,15 @@
(trampoline (eval-expr (thunk-expr result) (thunk-env result)))
result)))))
;; Cond/case helpers
(define *strict* false)
(define set-strict! (fn (val) (set! *strict* val)))
;; Special form constructors — build state for CEK evaluation
(define *prim-param-types* nil)
(define set-prim-param-types! (fn (types) (set! *prim-param-types* types)))
;; Quasiquote expansion
(define
value-matches-type?
(fn
@@ -577,7 +600,7 @@
(env-bind! local "children" children))
(make-thunk (component-body comp) local))))
;; Quasiquote expansion
;; Macro expansion — expand then re-evaluate the result
(define
parse-keyword-args
(fn
@@ -609,6 +632,14 @@
raw-args)
(list kwargs children))))
;; ═══════════════════════════════════════════════════════════════
;; Part 6: CEK Machine Core
;;
;; cek-run: trampoline loop — steps until terminal.
;; cek-step: single step — dispatches on phase (eval vs continue).
;; step-eval: evaluates control expression, pushes frames.
;; step-continue: pops a frame, processes result.
;; ═══════════════════════════════════════════════════════════════
(define
cond-scheme?
(fn
@@ -683,6 +714,12 @@
((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
(cek-call loop-fn init-vals))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 7: Special Form Step Functions
;;
;; Each step-sf-* handles one special form in the eval phase.
;; They push frames and return new CEK states — never recurse.
;; ═══════════════════════════════════════════════════════════════
(define
sf-lambda
(fn
@@ -712,6 +749,7 @@
params-expr)))
(make-lambda param-names body env))))
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
(define
sf-defcomp
(fn
@@ -749,7 +787,9 @@
(env-bind! env (symbol-name name-sym) comp)
comp))))
;; Macro expansion — expand then re-evaluate the result
;; List evaluation — dispatches on head: special forms, macros,
;; higher-order forms, or function calls. This is the main
;; expression dispatcher for the CEK machine.
(define
defcomp-kwarg
(fn
@@ -772,14 +812,7 @@
(range 2 end 1))
result)))
;; ═══════════════════════════════════════════════════════════════
;; Part 6: CEK Machine Core
;;
;; cek-run: trampoline loop — steps until terminal.
;; cek-step: single step — dispatches on phase (eval vs continue).
;; step-eval: evaluates control expression, pushes frames.
;; step-continue: pops a frame, processes result.
;; ═══════════════════════════════════════════════════════════════
;; call/cc: capture entire kont as undelimited escape continuation
(define
parse-comp-params
(fn
@@ -851,6 +884,31 @@
(env-bind! env (symbol-name name-sym) island)
island))))
(define
defio-parse-kwargs!
(fn
(spec remaining)
(when
(and
(not (empty? remaining))
(>= (len remaining) 2)
(keyword? (first remaining)))
(dict-set! spec (keyword-name (first remaining)) (nth remaining 1))
(defio-parse-kwargs! spec (rest (rest remaining))))))
;; Pattern matching (match form)
(define
sf-defio
(fn
(args env)
(let
((name (first args)) (spec (dict)))
(dict-set! spec "name" name)
(defio-parse-kwargs! spec (rest args))
(io-register! name spec)
spec)))
;; Condition system special forms
(define
sf-defmacro
(fn
@@ -867,12 +925,6 @@
(env-bind! env (symbol-name name-sym) mac)
mac))))
;; ═══════════════════════════════════════════════════════════════
;; Part 7: Special Form Step Functions
;;
;; Each step-sf-* handles one special form in the eval phase.
;; They push frames and return new CEK states — never recurse.
;; ═══════════════════════════════════════════════════════════════
(define
parse-macro-params
(fn
@@ -901,7 +953,6 @@
params-expr)
(list params rest-param))))
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
(define
qq-expand
(fn
@@ -941,9 +992,6 @@
(list)
template)))))))
;; List evaluation — dispatches on head: special forms, macros,
;; higher-order forms, or function calls. This is the main
;; expression dispatcher for the CEK machine.
(define
sf-letrec
(fn
@@ -999,7 +1047,6 @@
(slice body 0 (dec (len body))))
(make-thunk (last body) local))))
;; call/cc: capture entire kont as undelimited escape continuation
(define
step-sf-letrec
(fn
@@ -1045,7 +1092,6 @@
(scope-pop! name)
result))))
;; Pattern matching (match form)
(define
sf-provide
(fn
@@ -1062,7 +1108,6 @@
(scope-pop! name)
result)))
;; Condition system special forms
(define
expand-macro
(fn
@@ -1265,6 +1310,7 @@
env
kont))))
;; Scope/provide/context — structured downward data passing
(define
step-eval-list
(fn
@@ -1304,6 +1350,8 @@
("defcomp" (make-cek-value (sf-defcomp args env) env kont))
("defisland" (make-cek-value (sf-defisland args env) env kont))
("defmacro" (make-cek-value (sf-defmacro args env) env kont))
("defio" (make-cek-value (sf-defio args env) env kont))
("io" (step-sf-io args env kont))
("begin" (step-sf-begin args env kont))
("do"
(if
@@ -1527,6 +1575,7 @@
env
(kont-push (make-perform-frame env) kont)))))
;; Delimited continuations
(define
step-sf-callcc
(fn
@@ -1553,6 +1602,7 @@
(list local body)
(match-find-clause val (rest clauses) env))))))
;; Signal dereferencing with reactive dependency tracking
(define
match-pattern
(fn
@@ -1585,7 +1635,13 @@
pairs)))
:else (= pattern value))))
;; Scope/provide/context — structured downward data passing
;; ═══════════════════════════════════════════════════════════════
;; Part 8: Call Dispatch
;;
;; cek-call: invoke a function from native code (runs a nested
;; trampoline). step-eval-call: CEK-native call dispatch for
;; lambda, component, native fn, and continuations.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-match
(fn
@@ -1600,6 +1656,7 @@
(error (str "match: no clause matched " (inspect val)))
(make-cek-state (nth result 1) (first result) kont))))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define
step-sf-handler-bind
(fn
@@ -1647,6 +1704,13 @@
env
(kont-push (make-restart-frame restarts (list) env) kont)))))
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-signal
(fn
@@ -1692,7 +1756,6 @@
(env-bind! restart-env (first params) restart-arg))
(make-cek-state body restart-env rest-kont)))))))
;; Delimited continuations
(define
step-sf-if
(fn
@@ -1716,7 +1779,6 @@
env
(kont-push (make-when-frame (rest args) env) kont))))
;; Signal dereferencing with reactive dependency tracking
(define
step-sf-begin
(fn
@@ -1732,13 +1794,6 @@
env
(kont-push (make-begin-frame (rest args) env) kont))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 8: Call Dispatch
;;
;; cek-call: invoke a function from native code (runs a nested
;; trampoline). step-eval-call: CEK-native call dispatch for
;; lambda, component, native fn, and continuations.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-let
(fn
@@ -1783,7 +1838,6 @@
(make-let-frame vname rest-bindings body local)
kont)))))))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define
step-sf-define
(fn
@@ -1831,13 +1885,6 @@
env
(kont-push (make-set-frame (symbol-name (first args)) env) kont))))
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-and
(fn
@@ -1895,6 +1942,14 @@
env
(kont-push (make-cond-frame args env false) kont)))))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-case
(fn
@@ -1904,6 +1959,9 @@
env
(kont-push (make-case-frame nil (rest args) env) kont))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
(define
step-sf-thread-first
(fn
@@ -1917,6 +1975,13 @@
step-sf-lambda
(fn (args env kont) (make-cek-value (sf-lambda args env) env kont)))
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-scope
(fn
@@ -2022,14 +2087,6 @@
env
kont))))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-reset
(fn
@@ -2039,9 +2096,6 @@
env
(kont-push (make-reset-frame env) kont))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
(define
step-sf-shift
(fn
@@ -2068,13 +2122,6 @@
env
(kont-push (make-deref-frame env) kont))))
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(define
cek-call
(fn

101
spec/tests/test-io-registry.sx Normal file
View File

@@ -0,0 +1,101 @@
;; IO registry tests — defio, *io-registry*, accessor functions, io contract
(defsuite
"io-registry-basic"
(deftest
"defio registers an IO operation"
(defio
"test-io-basic"
:category :data
:params ()
:returns "string"
:doc "Basic test op.")
(assert (io-registered? "test-io-basic")))
(deftest
"io-lookup returns spec dict"
(defio
"test-io-lookup"
:category :effect
:params (x)
:returns "nil"
:doc "Test effect.")
(let
((spec (io-lookup "test-io-lookup")))
(assert= (get spec "name") "test-io-lookup")
(assert= (keyword-name (get spec "category")) "effect")
(assert= (get spec "returns") "nil")
(assert= (get spec "doc") "Test effect.")))
(deftest
"io-registered? returns false for unknown"
(assert (not (io-registered? "nonexistent-io-op"))))
(deftest
"io-names includes registered ops"
(defio
"test-io-names"
:category :data
:params ()
:returns "any"
:doc "Names test.")
(assert (contains? (io-names) "test-io-names")))
(deftest
"defio returns the spec dict"
(let
((result (defio "test-io-ret" :category :code :params (a b) :returns "string" :doc "Return test.")))
(assert= (get result "name") "test-io-ret")
(assert= (keyword-name (get result "category")) "code"))))
(defsuite
"io-registry-kwargs"
(deftest
"defio parses batchable flag"
(defio
"test-io-batch"
:category :code
:params (code lang)
:returns "string"
:batchable true
:doc "Batchable op.")
(assert= (get (io-lookup "test-io-batch") "batchable") true))
(deftest
"defio parses cacheable flag"
(defio
"test-io-cache"
:category :data
:params ()
:returns "list"
:cacheable true
:doc "Cacheable op.")
(assert= (get (io-lookup "test-io-cache") "cacheable") true))
(deftest
"defio parses params list"
(defio
"test-io-params"
:category :data
:params (a b c)
:returns "list"
:doc "Multi param.")
(assert= (len (get (io-lookup "test-io-params") "params")) 3)))
(defsuite
"io-contract"
(deftest
"io rejects unregistered operations"
(let
((caught false))
(try-catch
(fn () (io "totally-unknown-op-xyz"))
(fn (err) (set! caught true)))
(assert caught)))
(deftest
"io suspends for registered operations"
(defio
"test-io-contract"
:category :data
:params ()
:returns "string"
:doc "Contract test.")
(let
((caught-msg ""))
(try-catch
(fn () (io "test-io-contract"))
(fn (err) (set! caught-msg err)))
(assert (not (string-contains? caught-msg "unknown operation"))))))