radar: pass 40 — migration critical-path gate substantially closed; lib/host now 10 modules/181 incl blog read+write path

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>

.claude/scheduled_tasks.lock

@@ -1 +1 @@
-{"sessionId":"c4d97db1-361c-4a04-a99b-c838f9385469","pid":2426590,"procStart":"349789073","acquiredAt":1780789990975}
+{"sessionId":"bf20a443-9df8-4cb9-932e-8c6f4c4625c2","pid":1303602,"procStart":"253831081","acquiredAt":1779865895644}

applications/sxtp/spec.sx

@@ -97,42 +97,6 @@
       (:body "Any SX value — event payload (optional)")
       (:time "Number — unix timestamp (optional)"))))
 
-;; ── patch (DOM fragment patch — borrowed from Datastar) ───────────
-;; A server-driven instruction to morph a region of the client DOM.
-;; Subsumes HTMX swap modes; the :body is an SX subtree that the client
-;; renders to DOM nodes before applying the mode at the target.
-(define
-  patch-fields
-  (quote
-    ((:target "String — CSS selector for the element to patch (required)")
-      (:mode "Symbol — patch mode (optional, default outer)")
-      (:body "SX tree — the new content (omitted for mode remove)")
-      (:transition "Boolean — use a view transition (optional, default false)"))))
-
-(define
-  patch-modes
-  (quote
-    ((outer "Replace the target's outerHTML (default; the morph target)")
-      (inner "Replace the target's innerHTML, preserving the wrapper")
-      (replace "Hard-replace without morphing (no diff, plain swap)")
-      (prepend "Insert the body as the target's first child")
-      (append "Insert the body as the target's last child")
-      (before "Insert the body before the target")
-      (after "Insert the body after the target")
-      (remove "Detach the target; :body MUST be absent"))))
-
-;; ── signals (reactive state patch — borrowed from Datastar) ──────
-;; A server-driven update to client-side reactive signals. :values is a
-;; dict of signal-name -> new-value; setting a value to nil REMOVES the
-;; signal. With :only-if-missing true, existing signals are not touched
-;; (use this to lazily initialise signal state without clobbering).
-(define
-  signals-fields
-  (quote
-    ((:values "Dict — signal-name -> new-value (required)")
-      (:only-if-missing
-        "Boolean — only set signals that don't yet exist (optional, default false)"))))
-
 (define
   example-navigate
   (quote
@@ -184,23 +148,6 @@
           :message "No such post"
           :retry false)))))
 
-;; A streaming response intermixing patch + signals: the server pushes
-;; DOM updates AND signal updates over the same channel. The client
-;; dispatches each message by its head symbol; ordering is preserved.
-(define
-  example-patch-stream
-  (quote
-    ((request :verb subscribe :path "/cart/live" :capabilities (fetch))
-      (response :status ok :stream true)
-      (signals :values {:cart/count 3 :cart/loading false})
-      (patch
-        :target "#cart-mini"
-        :mode outer
-        :body (~cart-mini :count 3 :total 47.50))
-      (patch :target "#flash" :mode inner :body (p "Item added."))
-      (signals :values {:cart/loading true})
-      (patch :target "#cart-loading-spinner" :mode remove))))
-
 (define
   example-inspect
   (quote

docker-compose.dev-sx-host.yml

@@ -1,58 +0,0 @@
-# host-on-sx live service — the SX web host (lib/host) served by the native
-# http-listen server via lib/host/serve.sh. Joins the sx-dev project + externalnet
-# so Caddy can reverse_proxy a subdomain to it (blog.rose-ash.com). Isolated from
-# the sx_docs server: separate container, separate port.
-#
-# Usage:
-#   docker compose -p sx-dev -f docker-compose.dev-sx-host.yml up -d sx_host
-#   docker compose -p sx-dev -f docker-compose.dev-sx-host.yml logs -f sx_host
-#   docker compose -p sx-dev -f docker-compose.dev-sx-host.yml down
-
-services:
-  sx_host:
-    image: registry.rose-ash.com:5000/sx_docs:latest
-    container_name: sx-dev-sx_host-1
-    entrypoint: ["bash", "/app/lib/host/serve.sh"]
-    working_dir: /app
-    environment:
-      SX_PROJECT_DIR: /app
-      SX_SERVER: /app/bin/sx_server
-      HOST_PORT: "8000"
-      # Bind all interfaces so Caddy (on externalnet) can reach it.
-      SX_HTTP_HOST: "0.0.0.0"
-      # Durable persist store root — on a named volume so data survives restarts.
-      SX_PERSIST_DIR: /data/persist
-      # Blog write auth: admin login + session-cookie signing secret. The blog
-      # write routes (POST /new, POST/PUT/DELETE /posts) are guarded by a session
-      # login or Bearer token, so these gate publishing. Not a real site — these
-      # are demo creds; rotate by editing here and recreating the container.
-      SX_ADMIN_USER: admin
-      SX_ADMIN_PASSWORD: "sx-host-camper-van-2026"
-      SX_SESSION_SECRET: "ra-host-sess-7c1f9b3e2a8d4056"
-      # Serving-mode JIT: bytecode-compile hot SX (esp. the Datalog/relations path)
-      # on the epoch serving channel. Validated: host conformance 271/271 under JIT,
-      # 5.4x faster (1m43s -> 19s). Default-OFF gate, opt in here.
-      SX_SERVING_JIT: "1"
-      OCAMLRUNPARAM: "b"
-    volumes:
-      # SX source (hot-reload on container restart)
-      - ./spec:/app/spec:ro
-      - ./lib:/app/lib:ro
-      - ./web:/app/web:ro
-      # Client assets for the blog SPA: the WASM OCaml kernel + sx-platform + the
-      # web-stack modules, served by lib/host/static.sx at /static/**.
-      - ./shared/static:/app/shared/static:ro
-      # OCaml server binary — this worktree's build (has the SX_HTTP_HOST bind fix)
-      - ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
-      # Durable persist store (the SX op-log/kv on disk) — survives restarts.
-      # Host dir, chowned to the image's appuser (uid 10001) so the non-root
-      # server can write: sudo mkdir -p /root/sx-host-persist && sudo chown 10001:10001 /root/sx-host-persist
-      - /root/sx-host-persist:/data/persist
-    networks:
-      - externalnet
-      - default
-    restart: unless-stopped
-
-networks:
-  externalnet:
-    external: true

hosts/ocaml/bin/dune

@@ -1,5 +1,5 @@
 (executables
- (names run_tests debug_set sx_server integration_tests bench_cek bench_inspect bench_vm repro_jit_resume)
+ (names run_tests debug_set sx_server integration_tests bench_cek bench_inspect bench_vm)
  (libraries sx unix threads.posix otfm yojson))
 
 (executable

hosts/ocaml/bin/integration_tests.ml

@@ -263,7 +263,7 @@ let make_integration_env () =
 
   (* Type predicates — needed by adapter-sx.sx *)
   bind "callable?" (fun args ->
-    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true | _ -> Bool false);
+    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
   bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
   bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
   bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);

hosts/ocaml/bin/mcp_tree.ml

@@ -477,7 +477,7 @@ let setup_env () =
   bind "number?" (fun args -> match args with
     | [Number _] -> Bool true | _ -> Bool false);
   bind "callable?" (fun args -> match args with
-    | [NativeFn _ | Lambda _ | Component _ | Island _ | VmClosure _] -> Bool true | _ -> Bool false);
+    | [NativeFn _ | Lambda _ | Component _ | Island _] -> Bool true | _ -> Bool false);
   bind "empty?" (fun args -> match args with
     | [List []] | [ListRef { contents = [] }] -> Bool true
     | [Nil] -> Bool true | _ -> Bool false);

hosts/ocaml/bin/repro_jit_resume.ml

@@ -1,202 +0,0 @@
-(* Surgical repro for the serving-JIT OP_PERFORM/resume stack misalignment.
-   Mirrors what register_jit_hook's resolve_loop does: call_closure, catch
-   VmSuspended, resolve IO (return Nil), resume_vm — looping on re-suspend.
-   No CEK evaluator needed for the direct/multi-frame/reuse paths. *)
-
-open Sx_types
-
-let req_dict () =
-  let h = Hashtbl.create 1 in
-  Hashtbl.replace h "op" (String "noop");
-  Dict h
-
-(* Mirror the serving hook's resolve loop exactly. *)
-let drive cl =
-  let globals = cl.vm_closure_env |> ignore; cl.vm_env_ref in
-  let rec resolve_loop req vm =
-    let _ = req in
-    (try Sx_vm.resume_vm vm Nil
-     with Sx_vm.VmSuspended (r2, v2) -> resolve_loop r2 v2)
-  in
-  try Sx_vm.call_closure cl [] globals
-  with Sx_vm.VmSuspended (req, vm) -> resolve_loop req vm
-
-let mk_code ~locals ~bc ~consts = {
-  vc_arity = 0; vc_rest_arity = -1; vc_locals = locals;
-  vc_bytecode = Array.of_list bc;
-  vc_constants = Array.of_list consts;
-  vc_bytecode_list = None; vc_constants_list = None;
-}
-
-let mk_cl ?(name="tf") ?(env=Hashtbl.create 64) code =
-  { vm_code = code; vm_upvalues = [||]; vm_name = Some name;
-    vm_env_ref = env; vm_closure_env = None }
-
-let report label v =
-  Printf.printf "%-28s => %s\n%!" label (Sx_runtime.value_to_str v)
-
-let run label f =
-  (try report label (f ())
-   with
-   | Eval_error m -> Printf.printf "%-28s => ERROR: %s\n%!" label m
-   | e -> Printf.printf "%-28s => EXN: %s\n%!" label (Printexc.to_string e))
-
-(* opcodes *)
-let _const i = [1; i land 0xff; (i lsr 8) land 0xff]
-let _perform = [112]
-let _pop = [5]
-let _call_prim idx argc = [52; idx land 0xff; (idx lsr 8) land 0xff; argc]
-let _call argc = [48; argc]
-let _return = [50]
-
-let () =
-  (* Serving mode: a synchronous IO resolver is installed (mirrors
-     sx_server's http setup). Our mock resolves every request to Nil. *)
-  Sx_types._cek_io_resolver := Some (fun _req _ -> Nil);
-
-  (* Case 1: direct OP_PERFORM then a list prim in the SAME frame.
-     (do (perform {..}) (rest (list 1 2 3)))  =>  (2 3) *)
-  run "1.direct perform→rest" (fun () ->
-    let consts = [ req_dict (); List [Number 1.; Number 2.; Number 3.]; String "rest" ] in
-    let bc = _const 0 @ _perform @ _pop @ _const 1 @ _call_prim 2 1 @ _return in
-    drive (mk_cl (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 2: direct perform then map (2-arg prim).
-     (do (perform {..}) (map inc (list 1 2 3)))  — needs a fn; use a NativeFn const *)
-  run "2.direct perform→map" (fun () ->
-    let inc = NativeFn ("inc1", function [Number n] -> Number (n +. 1.) | _ -> Nil) in
-    let consts = [ req_dict (); inc; List [Number 1.; Number 2.; Number 3.]; String "map" ] in
-    (* push fn, push list, CALL_PRIM map 2 *)
-    let bc = _const 0 @ _perform @ _pop @ _const 1 @ _const 2 @ _call_prim 3 2 @ _return in
-    drive (mk_cl (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 3: multi-frame — outer calls a JIT'd helper that performs, THEN outer maps.
-     helper: (do (perform {..}) 99)
-     outer:  (do (helper) (map inc (list 1 2 3))) *)
-  run "3.multiframe perform→map" (fun () ->
-    let env = Hashtbl.create 64 in
-    let helper_code = mk_code ~locals:0
-      ~bc:(_const 0 @ _perform @ _pop @ _const 1 @ _return)
-      ~consts:[ req_dict (); Number 99. ] in
-    let helper_cl = mk_cl ~name:"helper" ~env helper_code in
-    let inc = NativeFn ("inc1", function [Number n] -> Number (n +. 1.) | _ -> Nil) in
-    let consts = [ VmClosure helper_cl; inc; List [Number 1.; Number 2.; Number 3.]; String "map" ] in
-    (* push helper-closure, CALL 0, POP its result, push inc, push list, CALL_PRIM map 2 *)
-    let bc = _const 0 @ _call 0 @ _pop @ _const 1 @ _const 2 @ _call_prim 3 2 @ _return in
-    drive (mk_cl ~name:"outer" ~env (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 4: map whose CALLBACK performs (reuse_stack path), then a trailing prim.
-     callback: (do (perform {..}) (inc e))   — but callback gets arg e in slot 0
-     outer: (do (map cb (list 1 2 3)) (rest (list 7 8 9)))  *)
-  run "4.map-callback-perform" (fun () ->
-    let env = Hashtbl.create 64 in
-    (* callback arity 1: slot0 = e. body: (perform {..}); (inc e) ; return
-       LOCAL_GET 0 then CALL_PRIM inc... use NativeFn inc via CALL_PRIM *)
-    let cb_code = {
-      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
-      vc_bytecode = Array.of_list (_const 0 @ _perform @ _pop
-                                   @ [16;0] (* LOCAL_GET 0 *)
-                                   @ _call_prim 1 1 @ _return);
-      vc_constants = [| req_dict (); String "inc" |];
-      vc_bytecode_list = None; vc_constants_list = None } in
-    let cb_cl = mk_cl ~name:"cb" ~env cb_code in
-    let consts = [ VmClosure cb_cl; List [Number 1.; Number 2.; Number 3.]; String "map";
-                   List [Number 7.; Number 8.; Number 9.]; String "rest" ] in
-    (* push cb, push list, CALL_PRIM map 2, POP, push list2, CALL_PRIM rest 1, RETURN *)
-    let bc = _const 0 @ _const 1 @ _call_prim 2 2 @ _pop @ _const 3 @ _call_prim 4 1 @ _return in
-    drive (mk_cl ~name:"outer4" ~env (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 5: THE HOST CASE — perform via an INTERPRETED helper (pending_cek path),
-     then a list prim. helper is a Lambda (l_compiled = jit_failed) whose body
-     performs; vm_call routes it through cek_call_or_suspend → pending_cek.
-       helper: (perform {..})  [interpreted via CEK]
-       outer:  (do (helper) (rest (list 1 2 3)))  => (2 3) *)
-  run "5.pending_cek perform→rest" (fun () ->
-    let env = Sx_types.make_env () in
-    let helper = Lambda {
-      l_params = []; l_body = List [Symbol "perform"; req_dict ()];
-      l_closure = env; l_name = Some "kvread";
-      l_compiled = Some Sx_vm.jit_failed_sentinel; l_call_count = 0;
-      l_uid = Sx_types.next_lambda_uid () } in
-    let consts = [ helper; List [Number 1.; Number 2.; Number 3.]; String "rest" ] in
-    (* push helper, CALL 0, POP, push list, CALL_PRIM rest 1, RETURN *)
-    let bc = _const 0 @ _call 0 @ _pop @ _const 1 @ _call_prim 2 1 @ _return in
-    drive (mk_cl ~name:"outer5" ~env:(Hashtbl.create 64) (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 6: pending_cek perform → MAP (2-arg), the exact host shape. *)
-  run "6.pending_cek perform→map" (fun () ->
-    let env = Sx_types.make_env () in
-    let helper = Lambda {
-      l_params = []; l_body = List [Symbol "perform"; req_dict ()];
-      l_closure = env; l_name = Some "kvread";
-      l_compiled = Some Sx_vm.jit_failed_sentinel; l_call_count = 0;
-      l_uid = Sx_types.next_lambda_uid () } in
-    let inc = NativeFn ("inc1", function [Number n] -> Number (n +. 1.) | _ -> Nil) in
-    let consts = [ helper; inc; List [Number 1.; Number 2.; Number 3.]; String "map" ] in
-    (* push helper, CALL 0, POP, push inc, push list, CALL_PRIM map 2, RETURN *)
-    let bc = _const 0 @ _call 0 @ _pop @ _const 1 @ _const 2 @ _call_prim 3 2 @ _return in
-    drive (mk_cl ~name:"outer6" ~env:(Hashtbl.create 64) (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 7: THE HOST SHAPE — map whose callback calls an INTERPRETED helper
-     that performs (kv read via persist helper inside a map), THEN a trailing
-     prim. callback(e): (do (kvread) e)  — kvread suspends via pending_cek.
-     outer: (do (map cb (list 1 2 3)) (drop (list 5 6 7 8) 2)) => (7 8) *)
-  run "7.HOST: map[cb→helper perform]→drop" (fun () ->
-    let genv = Sx_types.make_env () in
-    let helper = Lambda {
-      l_params = []; l_body = List [Symbol "perform"; req_dict ()];
-      l_closure = genv; l_name = Some "kvread";
-      l_compiled = Some Sx_vm.jit_failed_sentinel; l_call_count = 0;
-      l_uid = Sx_types.next_lambda_uid () } in
-    let env = Hashtbl.create 64 in
-    (* cb(e): push helper, CALL 0, POP, LOCAL_GET 0, RETURN *)
-    let cb_code = {
-      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
-      vc_bytecode = Array.of_list (_const 0 @ _call 0 @ _pop @ [16;0] @ _return);
-      vc_constants = [| helper |]; vc_bytecode_list=None; vc_constants_list=None } in
-    let cb_cl = mk_cl ~name:"cb7" ~env cb_code in
-    let consts = [ VmClosure cb_cl; List [Number 1.; Number 2.; Number 3.]; String "map";
-                   List [Number 5.; Number 6.; Number 7.; Number 8.]; Number 2.; String "drop" ] in
-    (* push cb, push list, CALL_PRIM map 2, POP, push list2, push 2, CALL_PRIM drop 2, RETURN *)
-    let bc = _const 0 @ _const 1 @ _call_prim 2 2 @ _pop
-             @ _const 3 @ _const 4 @ _call_prim 5 2 @ _return in
-    drive (mk_cl ~name:"outer7" ~env (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 8: reduce whose callback performs. (reduce + 0 (list 1 2 3)) with a
-     perform in the reducer => 6 *)
-  run "8.reduce[acc→perform]" (fun () ->
-    let env = Hashtbl.create 64 in
-    (* reducer(acc e): (do (perform {..}) (+ acc e)). slots: 0=acc 1=e *)
-    let rd_code = {
-      vc_arity = 2; vc_rest_arity = -1; vc_locals = 2;
-      vc_bytecode = Array.of_list (_const 0 @ _perform @ _pop
-                                   @ [16;0] @ [16;1] @ _call_prim 1 2 @ _return);
-      vc_constants = [| req_dict (); String "+" |];
-      vc_bytecode_list=None; vc_constants_list=None } in
-    let rd_cl = mk_cl ~name:"rd" ~env rd_code in
-    let consts = [ VmClosure rd_cl; Number 0.; List [Number 1.; Number 2.; Number 3.]; String "reduce" ] in
-    (* push reducer, push 0, push list, CALL_PRIM reduce 3, RETURN *)
-    let bc = _const 0 @ _const 1 @ _const 2 @ _call_prim 3 3 @ _return in
-    drive (mk_cl ~name:"outer8" ~env (mk_code ~locals:0 ~bc ~consts)));
-
-  (* Case 9: nested map — outer map callback runs an inner map whose callback
-     performs. outer over (list 1 2), inner over (list 10 20) performing.
-     cb_outer(x): (map cb_inner (list 10 20)) ; cb_inner(y): (do (perform) y)
-     => ((10 20) (10 20)) *)
-  run "9.nested map[inner→perform]" (fun () ->
-    let env = Hashtbl.create 64 in
-    let inner_code = {
-      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
-      vc_bytecode = Array.of_list (_const 0 @ _perform @ _pop @ [16;0] @ _return);
-      vc_constants = [| req_dict () |]; vc_bytecode_list=None; vc_constants_list=None } in
-    let inner_cl = mk_cl ~name:"cbin" ~env inner_code in
-    (* outer cb(x): push inner_cl, push (10 20), CALL_PRIM map 2, RETURN *)
-    let outer_cb_code = {
-      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
-      vc_bytecode = Array.of_list (_const 0 @ _const 1 @ _call_prim 2 2 @ _return);
-      vc_constants = [| VmClosure inner_cl; List [Number 10.; Number 20.]; String "map" |];
-      vc_bytecode_list=None; vc_constants_list=None } in
-    let outer_cb_cl = mk_cl ~name:"cbout" ~env outer_cb_code in
-    let consts = [ VmClosure outer_cb_cl; List [Number 1.; Number 2.]; String "map" ] in
-    let bc = _const 0 @ _const 1 @ _call_prim 2 2 @ _return in
-    drive (mk_cl ~name:"outer9" ~env (mk_code ~locals:0 ~bc ~consts)))

hosts/ocaml/bin/run_tests.ml

@@ -595,7 +595,7 @@ let make_test_env () =
   (* regex-find-all now provided by sx_primitives.ml *)
   bind "callable?" (fun args ->
     match args with
-    | [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true
+    | [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true
     | _ -> Bool false);
   bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
   bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
@@ -2812,13 +2812,10 @@ let run_spec_tests env test_files =
               | "insertAdjacentHTML" | "prepend" | "showModal" | "show" | "close"
               | "getBoundingClientRect" | "getAnimations" | "scrollIntoView"
               | "scrollTo" | "scroll" | "reset" -> Bool true
-              | "firstElementChild" | "firstChild" ->
-                (* the mock treats element children and child nodes alike, so
-                   firstChild == firstElementChild — children-to-fragment walks
-                   firstChild to drain a parsed fragment into a swap target. *)
+              | "firstElementChild" ->
                 let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
                 (match kids with c :: _ -> c | [] -> Nil)
-              | "lastElementChild" | "lastChild" ->
+              | "lastElementChild" ->
                 let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
                 (match List.rev kids with c :: _ -> c | [] -> Nil)
               | "nextElementSibling" | "nextSibling" ->
@@ -2964,15 +2961,6 @@ let run_spec_tests env test_files =
        | "setTimeout" -> (match rest with fn :: _ -> ignore (Sx_ref.cek_call fn (List [])); Nil | _ -> Nil)
        | "clearTimeout" -> Nil
        | _ -> Nil)
-    (* NodeList.item(i) — dom-query-all iterates the querySelectorAll result
-       (a bare List) via this method, exactly like a browser NodeList. *)
-    | (List _ | ListRef _) :: String "item" :: [idx] ->
-      let items = match args with
-        | List l :: _ -> l
-        | ListRef { contents = l } :: _ -> l
-        | _ -> [] in
-      let i = match idx with Number n -> int_of_float n | Integer n -> n | _ -> -1 in
-      if i >= 0 && i < List.length items then List.nth items i else Nil
     | Dict d :: String "hasOwnProperty" :: [String k] ->
       Bool (Hashtbl.mem d k)
     | Dict d :: String m :: rest ->
@@ -3082,26 +3070,6 @@ let run_spec_tests env test_files =
         (* console.log/debug/error — no-op in tests *)
         Nil
 
-      else if mt = "domparser" then
-        (* DOMParser.parseFromString(text, "text/html") — returns a mock
-           document whose <body> is parsed from `text`. An empty string yields
-           a valid empty document (truthy), matching the browser: that's what
-           the engine's handle-html-response relies on for an empty-body
-           sx-swap="delete" response. *)
-        (match m with
-         | "parseFromString" ->
-           let text = match rest with String t :: _ -> t | _ -> "" in
-           let bd = match make_mock_element "body" with Dict d -> d | _ -> Hashtbl.create 0 in
-           Hashtbl.replace bd "tagName" (String "BODY");
-           Hashtbl.replace bd "nodeName" (String "BODY");
-           parse_html_into bd text;
-           Hashtbl.replace bd "innerHTML" (String text);
-           let doc = Hashtbl.create 4 in
-           Hashtbl.replace doc "__mock_type" (String "document");
-           Hashtbl.replace doc "body" (Dict bd);
-           Dict doc
-         | _ -> Nil)
-
       else
         (* Element methods *)
         (match m with
@@ -3515,10 +3483,6 @@ let run_spec_tests env test_files =
       Dict ev
     | [String "Object"] ->
       Dict (Hashtbl.create 4)
-    | [String "DOMParser"] ->
-      let d = Hashtbl.create 4 in
-      Hashtbl.replace d "__mock_type" (String "domparser");
-      Dict d
     | _ -> Nil);
 
   reg "host-callback" (fun args ->
@@ -3696,7 +3660,6 @@ let run_spec_tests env test_files =
   load_module "router.sx" web_dir;
   load_module "deps.sx" web_dir;
   load_module "orchestration.sx" web_dir;
-  load_module "console-render.sx" web_dir;
   (* Library modules for lib/tests/ *)
   load_module "bytecode.sx" lib_dir;
   load_module "compiler.sx" lib_dir;

hosts/ocaml/bin/sx_server.ml

@@ -32,14 +32,6 @@ let () = ignore (Sx_vm_extensions.id_of_name "")
    which we swallow so a re-entered server process doesn't die. *)
 let () = try Erlang_ext.register () with Failure _ -> ()
 
-(* Ignore SIGPIPE: a client that closes its connection mid-response (a browser
-   aborting an in-flight fetch — the SX engine cancels superseded requests on a
-   debounced filter or a fast nav) must NOT kill the server. SIGPIPE's default
-   action terminates the process before any exception is raised; ignoring it
-   turns the failed write into a catchable Sys_error (EPIPE), which the
-   per-connection handler already swallows, dropping just that one connection. *)
-let () = try Sys.set_signal Sys.sigpipe Sys.Signal_ignore with _ -> ()
-
 (* ====================================================================== *)
 (* Font measurement via otfm — reads OpenType/TrueType font tables         *)
 (* ====================================================================== *)
@@ -530,25 +522,26 @@ let rec load_library_file path =
       Printf.eprintf "[load-library] %s: %s\n%!" (Filename.basename path) msg
   ) exprs
 
-(* IO-aware CEK run (cek_run_with_io, below) — handles suspension by dispatching
-   IO requests. Import requests are handled locally (load .sx file). *)
-(** Resolve a single IO request value to its response. Shared by
-    cek_run_with_io's suspension loop AND the _cek_io_resolver installed for the
-    http-listen serving path, so the synchronous inline-resolve path (sx_vm.ml's
-    HO-callback suspend fix) resolves durable reads byte-identically to the
-    CEK-driven path. Without an installed resolver, a `perform` inside an HO
-    primitive callback (map/filter/…) unwinds the native loop and corrupts the
-    stack — the host's map/rest/drop serving-JIT miscompile. *)
-and resolve_io_request request =
+(** IO-aware CEK run — handles suspension by dispatching IO requests.
+    Import requests are handled locally (load .sx file).
+    Other IO requests are sent to the Python bridge. *)
+and cek_run_with_io state =
+  let s = ref state in
+  let is_terminal s = match Sx_ref.cek_terminal_p s with Bool true -> true | _ -> false in
+  let is_suspended s = match Sx_runtime.get_val s (String "phase") with String "io-suspended" -> true | _ -> false in
+  let rec loop () =
+    while not (is_terminal !s) && not (is_suspended !s) do
+      s := Sx_ref.cek_step !s
+    done;
+    if is_suspended !s then begin
+      let request = Sx_runtime.get_val !s (String "request") in
       let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in
-  (match op with
+      let response = match op with
         | "import" ->
           (* Resolve library locally — load the .sx file *)
           let lib_spec = Sx_runtime.get_val request (String "library") in
-     (* library_loaded_p takes the library SPEC and computes the key itself —
-        passing an already-computed key string double-applies library_name_key
-        and crashes (sx_to_list on a string). *)
-     if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then
+          let key = Sx_ref.library_name_key lib_spec in
+          if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
             (* Already loaded — just resume *)
             Nil
           else begin
@@ -578,24 +571,10 @@ and resolve_io_request request =
           Hashtbl.replace d "descent" (Number desc);
           Dict d
         | _ ->
-     let argsv = Sx_runtime.get_val request (String "args") in
-     (match Sx_persist_store.handle_op op argsv with
-      | Some resp -> resp
-      | None ->
-        let args = (match argsv with List l -> l | _ -> [argsv]) in
-        io_request op args))
-
-and cek_run_with_io state =
-  let s = ref state in
-  let is_terminal s = match Sx_ref.cek_terminal_p s with Bool true -> true | _ -> false in
-  let is_suspended s = match Sx_runtime.get_val s (String "phase") with String "io-suspended" -> true | _ -> false in
-  let rec loop () =
-    while not (is_terminal !s) && not (is_suspended !s) do
-      s := Sx_ref.cek_step !s
-    done;
-    if is_suspended !s then begin
-      let request = Sx_runtime.get_val !s (String "request") in
-      let response = resolve_io_request request in
+          let args = let a = Sx_runtime.get_val request (String "args") in
+            (match a with List l -> l | _ -> [a]) in
+          io_request op args
+      in
       s := Sx_ref.cek_resume !s response;
       loop ()
     end else
@@ -763,27 +742,9 @@ let setup_evaluator_bridge env =
         | _ -> raise (Eval_error "http-listen: (port handler)") in
       let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
       Unix.setsockopt sock Unix.SO_REUSEADDR true;
-      (* Bind host: loopback by default (safe for tests + local runs); set
-         SX_HTTP_HOST=0.0.0.0 to expose on the network (container/Caddy). *)
-      let bind_addr =
-        match Sys.getenv_opt "SX_HTTP_HOST" with
-        | Some h -> (try Unix.inet_addr_of_string h
-                     with _ -> Unix.inet_addr_loopback)
-        | None -> Unix.inet_addr_loopback in
       Unix.bind sock
-        (Unix.ADDR_INET (bind_addr, port));
+        (Unix.ADDR_INET (Unix.inet_addr_loopback, port));
       Unix.listen sock 64;
-      (* Install the synchronous IO resolver for the serving path. Without it, a
-         `perform` (durable kv read) that fires inside an HO-primitive callback
-         (map/filter/reduce/…) during request handling suspends through the
-         native OCaml loop, dropping its iteration state and leaving the stack
-         misaligned — the serving-JIT host miscompile (map/rest/drop wrong args,
-         blank pages, empty picker). With a resolver installed, sx_vm.ml resolves
-         that callback's IO inline (byte-identically to cek_run_with_io) and the
-         loop is never unwound. Only set if one isn't already installed. *)
-      (if !Sx_types._cek_io_resolver = None then
-         Sx_types._cek_io_resolver :=
-           Some (fun request _state -> resolve_io_request request));
       (* SX runtime is shared across threads — serialize handler calls. *)
       let mtx = Mutex.create () in
       let reason = function
@@ -843,31 +804,9 @@ let setup_evaluator_bridge env =
              Hashtbl.replace req "body" (String body);
              Mutex.lock mtx;
              let resp =
-               (* Run the handler through the IO-aware CEK runner (not bare
-                  sx_call) so request handlers can perform per-request IO —
-                  durable store reads/writes resolve via cek_run_with_io's
-                  suspension loop instead of returning an unresolved suspension.
-                  On ANY handler exception, synthesise a 500 response rather than
-                  letting it escape: an escaped exception drops the connection
-                  with no bytes written, which a reverse proxy (Caddy/Cloudflare)
-                  surfaces as a 502 error page. A real 500 keeps the origin
-                  responsive and debuggable. Note: a native exception (e.g. the
-                  parser's Parse_error) cannot be caught by an SX (guard ...), so
-                  this boundary is the only place it can be trapped. *)
-               (try
-                  let st = Sx_ref.continue_with_call handler
-                             (List [Dict req]) (Env (Sx_types.make_env ()))
-                             (List [Dict req]) (List []) in
-                  let r = cek_run_with_io st in
-                  Mutex.unlock mtx; r
-                with e ->
+               (try Sx_runtime.sx_call handler [Dict req]
+                with e -> Mutex.unlock mtx; raise e) in
              Mutex.unlock mtx;
-                  Printf.eprintf "[http-listen] handler error: %s\n%!"
-                    (Printexc.to_string e);
-                  let d = Sx_types.make_dict () in
-                  Hashtbl.replace d "status" (Integer 500);
-                  Hashtbl.replace d "body" (String "Internal Server Error");
-                  Dict d) in
              let getk k = match resp with
                | Dict h -> Hashtbl.find_opt h k | _ -> None in
              let status = match getk "status" with
@@ -893,18 +832,6 @@ let setup_evaluator_bridge env =
              List.iter (fun (k, v) ->
                Buffer.add_string buf
                  (Printf.sprintf "%s: %s\r\n" k v)) rhdrs;
-             (* Cookies: a response carries :set-cookies as a LIST of pre-formatted
-                cookie strings (Dream's dream-set-cookie), because a headers Dict
-                cannot hold more than one Set-Cookie. Emit one header per item. *)
-             (match getk "set-cookies" with
-              | Some (List items) ->
-                List.iter (fun v ->
-                  match v with
-                  | String s ->
-                    Buffer.add_string buf
-                      (Printf.sprintf "Set-Cookie: %s\r\n" s)
-                  | _ -> ()) items
-              | _ -> ());
              if not (List.exists
                        (fun (k, _) ->
                           String.lowercase_ascii k = "content-type")
@@ -928,164 +855,6 @@ let setup_evaluator_bridge env =
       done;
       Nil
     | _ -> raise (Eval_error "http-listen: (port handler)"));
-
-  (* fed-sx Milestone 1 client direction (Phase J). NATIVE ONLY —
-     Unix sockets + DNS; absent from the WASM kernel. HTTP/1.1
-     request: TCP connect, write request line + headers + body,
-     read status + headers + body, return {:status :headers :body}.
-     URL must be http://...; HTTPS is a later phase (needs TLS).
-     Body read: Content-Length first, else read to EOF (we send
-     Connection: close). Transfer-Encoding: chunked is rejected —
-     fed-sx Phase 8 wires this for inter-server POSTs which will
-     all carry Content-Length. *)
-  Sx_primitives.register "http-request" (fun args ->
-    let strip_cr s =
-      let n = String.length s in
-      if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
-    in
-    match args with
-    | [String meth; String url; headers_v; body_v] ->
-      let body = match body_v with
-        | String s -> s
-        | Nil -> ""
-        | v -> Sx_types.value_to_string v in
-      let prefix = "http://" in
-      let plen = String.length prefix in
-      let ulen = String.length url in
-      if ulen < plen || String.sub url 0 plen <> prefix
-      then raise (Eval_error "http-request: URL must start with http://");
-      let rest = String.sub url plen (ulen - plen) in
-      let host_port, path =
-        match String.index_opt rest '/' with
-        | Some i ->
-          String.sub rest 0 i,
-          String.sub rest i (String.length rest - i)
-        | None -> rest, "/" in
-      if host_port = "" then
-        raise (Eval_error "http-request: missing host");
-      let host, port =
-        match String.index_opt host_port ':' with
-        | Some i ->
-          let h = String.sub host_port 0 i in
-          let ps = String.sub host_port (i + 1)
-                     (String.length host_port - i - 1) in
-          (h,
-           (try int_of_string ps with _ ->
-              raise (Eval_error "http-request: bad port")))
-        | None -> host_port, 80 in
-      let addr =
-        (try (Unix.gethostbyname host).h_addr_list.(0)
-         with Not_found ->
-           raise (Eval_error ("http-request: dns: " ^ host))) in
-      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
-      let cleanup () = try Unix.close sock with _ -> () in
-      let result =
-        (try
-          (try Unix.connect sock (Unix.ADDR_INET (addr, port))
-           with Unix.Unix_error (e, _, _) ->
-             raise (Eval_error
-                      ("http-request: connect: " ^ Unix.error_message e)));
-          let oc = Unix.out_channel_of_descr sock in
-          let ic = Unix.in_channel_of_descr sock in
-          let buf = Buffer.create 256 in
-          Buffer.add_string buf
-            (Printf.sprintf "%s %s HTTP/1.1\r\n" meth path);
-          let host_hdr_sent = ref false in
-          let clen_sent = ref false in
-          let conn_sent = ref false in
-          (match headers_v with
-           | Dict h ->
-             Hashtbl.iter (fun k v ->
-               let kl = String.lowercase_ascii k in
-               if kl = "host" then host_hdr_sent := true;
-               if kl = "content-length" then clen_sent := true;
-               if kl = "connection" then conn_sent := true;
-               let vs = match v with
-                 | String s -> s
-                 | x -> Sx_types.value_to_string x in
-               Buffer.add_string buf
-                 (Printf.sprintf "%s: %s\r\n" k vs)) h
-           | Nil -> ()
-           | _ -> raise (Eval_error "http-request: headers must be dict"));
-          if not !host_hdr_sent then
-            Buffer.add_string buf
-              (Printf.sprintf "Host: %s\r\n" host_port);
-          if not !clen_sent then
-            Buffer.add_string buf
-              (Printf.sprintf "Content-Length: %d\r\n"
-                 (String.length body));
-          if not !conn_sent then
-            Buffer.add_string buf "Connection: close\r\n";
-          Buffer.add_string buf "\r\n";
-          Buffer.add_string buf body;
-          output_string oc (Buffer.contents buf);
-          flush oc;
-          let sl =
-            (try strip_cr (input_line ic)
-             with End_of_file ->
-               raise (Eval_error
-                        "http-request: connection closed before status")) in
-          let status =
-            match String.split_on_char ' ' sl with
-            | _ver :: code :: _ ->
-              (try int_of_string code with _ ->
-                 raise (Eval_error "http-request: bad status code"))
-            | _ -> raise (Eval_error "http-request: bad status line") in
-          let rhdrs = Sx_types.make_dict () in
-          let clen = ref (-1) in
-          let chunked = ref false in
-          let rec rdh () =
-            let h =
-              (try strip_cr (input_line ic)
-               with End_of_file -> "") in
-            if h = "" then ()
-            else begin
-              (match String.index_opt h ':' with
-               | Some i ->
-                 let name =
-                   String.lowercase_ascii
-                     (String.trim (String.sub h 0 i)) in
-                 let value =
-                   String.trim
-                     (String.sub h (i + 1)
-                        (String.length h - i - 1)) in
-                 Hashtbl.replace rhdrs name (String value);
-                 if name = "content-length" then
-                   (try clen := int_of_string value with _ -> ())
-                 else if name = "transfer-encoding" &&
-                         String.lowercase_ascii value = "chunked"
-                 then chunked := true
-               | None -> ());
-              rdh ()
-            end in
-          rdh ();
-          if !chunked then
-            raise (Eval_error
-                     "http-request: chunked transfer-encoding not supported");
-          let rbody =
-            if !clen >= 0 then begin
-              let b = Bytes.create !clen in
-              really_input ic b 0 !clen;
-              Bytes.unsafe_to_string b
-            end else begin
-              let b = Buffer.create 256 in
-              (try
-                 while true do
-                   Buffer.add_channel b ic 4096
-                 done; assert false
-               with End_of_file -> ());
-              Buffer.contents b
-            end in
-          let resp = Sx_types.make_dict () in
-          Hashtbl.replace resp "status" (Integer status);
-          Hashtbl.replace resp "headers" (Dict rhdrs);
-          Hashtbl.replace resp "body" (String rbody);
-          Dict resp
-        with e -> cleanup (); raise e) in
-      cleanup ();
-      result
-    | _ -> raise (Eval_error "http-request: (method url headers body)"));
-
   bind "trampoline" (fun args ->
     match args with
     | [v] ->
@@ -1167,11 +936,7 @@ let setup_introspection env =
   bind "component?" (fun args ->
     match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
   bind "callable?" (fun args ->
-    (* VmClosure must count as callable: a JIT-compiled higher-order function
-       returns its inner closure as a VmClosure, and downstream code (e.g.
-       scheme-apply's `(callable? proc)` guard) must recognize it — it is
-       invocable via the normal call path. *)
-    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true | _ -> Bool false);
+    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
   bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
   bind "continuation?" (fun args ->
     match args with [Continuation _] -> Bool true | [_] -> Bool false | _ -> Bool false);
@@ -1297,20 +1062,6 @@ let setup_type_constructors env =
       (* Already a value — return as-is *)
       v
     | _ -> raise (Eval_error "parse: expected string"));
-  (* Like parse, but returns nil instead of raising on malformed input. The
-     parser raises a native Parse_error that an SX-level (guard ...) cannot catch
-     (guard only traps SX conditions, not host exceptions), so code that handles
-     untrusted text — e.g. a stored post body — needs a value-returning parse to
-     degrade gracefully rather than crash the request. *)
-  bind "parse-safe" (fun args ->
-    match args with
-    | [String s] | [SxExpr s] ->
-      (try
-         let exprs = Sx_parser.parse_all s in
-         (match exprs with [e] -> e | _ -> List exprs)
-       with _ -> Nil)
-    | [v] -> v
-    | _ -> Nil);
   (* Native bytecode compiler — bootstrapped from lib/compiler.sx *)
   bind "compile" (fun args ->
     match args with [expr] -> Sx_compiler.compile expr | _ -> Nil);
@@ -1556,22 +1307,6 @@ let sx_render_to_html expr env =
 
 let _jit_warned : (string, bool) Hashtbl.t = Hashtbl.create 16
 
-(* Bisection aid: env-var-driven JIT filter. Lets us narrow which named
-   lambda the VM miscompiles without rebuilding.
-   SX_JIT_DENY=name1,name2  — never JIT these (substring match on exact name).
-   SX_JIT_ONLY=name1,name2  — JIT ONLY these (exact name); skip all others. *)
-let _jit_deny_set =
-  match Sys.getenv_opt "SX_JIT_DENY" with
-  | None | Some "" -> []
-  | Some s -> String.split_on_char ',' s |> List.map String.trim
-let _jit_only_set =
-  match Sys.getenv_opt "SX_JIT_ONLY" with
-  | None | Some "" -> []
-  | Some s -> String.split_on_char ',' s |> List.map String.trim
-let _jit_name_allowed name =
-  (not (List.mem name _jit_deny_set))
-  && (match _jit_only_set with [] -> true | only -> List.mem name only)
-
 let rec make_vm_suspend_marker request saved_vm =
   let d = Hashtbl.create 3 in
   Hashtbl.replace d "__vm_suspended" (Bool true);
@@ -1590,8 +1325,6 @@ let rec make_vm_suspend_marker request saved_vm =
 let register_jit_hook env =
   Sx_runtime._jit_try_call_fn := Some (fun f args ->
     match f with
-    | Lambda l when (match l.l_name with Some n -> not (_jit_name_allowed n) | None -> false) ->
-      None  (* bisection filter excluded this name *)
     | Lambda l ->
       (match l.l_compiled with
        | Some cl when not (Sx_vm.is_jit_failed cl) ->
@@ -1608,23 +1341,7 @@ let register_jit_hook env =
                let rec resolve_loop req vm =
                  let result = resolver req (Nil) in
                  (try Some (Sx_vm.resume_vm vm result)
-                  with
-                  | Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2
-                  | e ->
-                    (* (B) Resume raised mid-execution. resolve_loop runs inside
-                       the VmSuspended handler, so without catching here the
-                       error escapes to the http handler (→ 500). Recover THIS
-                       call on the CEK instead: mark jit_failed and return None
-                       so the interpreter re-runs it (idempotent for the host's
-                       durable reads). Self-heals on the first hit, not a retry. *)
-                    let fn_name = match l.l_name with Some n -> n | None -> "?" in
-                    if not (Hashtbl.mem _jit_warned fn_name) then begin
-                      Hashtbl.replace _jit_warned fn_name true;
-                      Printf.eprintf "[jit] %s resume fallback to CEK: %s\n%!"
-                        fn_name (Printexc.to_string e)
-                    end;
-                    l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
-                    None)
+                  with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2)
                in
                resolve_loop request saved_vm
              | None -> Some (make_vm_suspend_marker request saved_vm))
@@ -1657,16 +1374,7 @@ let register_jit_hook env =
                    let rec resolve_loop req vm =
                      let result = resolver req (Nil) in
                      (try Some (Sx_vm.resume_vm vm result)
-                      with
-                      | Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2
-                      | e ->
-                        (* (B) See note above — recover a failed resume on the
-                           CEK instead of escaping to the handler (→ 500). *)
-                        Printf.eprintf "[jit] %s resume fallback to CEK: %s\n%!"
-                          fn_name (Printexc.to_string e);
-                        Hashtbl.replace _jit_warned fn_name true;
-                        l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
-                        None)
+                      with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2)
                    in
                    resolve_loop request saved_vm
                  | None -> Some (make_vm_suspend_marker request saved_vm))
@@ -1798,10 +1506,6 @@ let rec dispatch env cmd =
         | Nil -> "nil"
         | Bool true -> "true" | Bool false -> "false"
         | Number n -> Sx_types.format_number n
-        (* Bytecode opcodes + arity/upvalue-count are Integers; without this case
-           they hit the `_ -> "nil"` fallthrough, so every .sxbc came out as
-           `:bytecode (nil nil ...)` -> "VM: unknown opcode 0" -> source fallback. *)
-        | Integer n -> string_of_int n
         | String s -> "\"" ^ escape_sx_string s ^ "\""
         | Symbol s -> s | Keyword k -> ":" ^ k
         | List items | ListRef { contents = items } -> "(" ^ String.concat " " (List.map raw_serialize items) ^ ")"
@@ -1829,20 +1533,14 @@ let rec dispatch env cmd =
             | _ -> "" in
           let response = if op = "import" then begin
             let lib_spec = Sx_runtime.get_val request (String "library") in
-            (* pass the SPEC, not a pre-computed key — library_loaded_p applies
-               library_name_key itself (a key string would crash sx_to_list). *)
-            if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then Nil
+            let key = Sx_ref.library_name_key lib_spec in
+            if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then Nil
             else begin
               (match resolve_library_path lib_spec with
                | Some path -> load_library_file path | None -> ());
               Nil
             end
-          end else
-            (* durable-storage ops: service against on-disk store *)
-            let args = Sx_runtime.get_val request (String "args") in
-            (match Sx_persist_store.handle_op op args with
-             | Some resp -> resp
-             | None -> Nil (* non-import IO: resume with nil *)) in
+          end else Nil (* non-import IO: resume with nil *) in
           s := Sx_ref.cek_resume !s response
         done;
         Sx_ref.cek_value !s
@@ -4195,10 +3893,7 @@ let http_mode port =
       Dict d
     | "io-sleep" | "sleep" -> Nil
     | "import" -> Nil
-    | _ ->
-      (match Sx_persist_store.handle_op op args with
-       | Some resp -> resp
-       | None -> Nil));
+    | _ -> Nil);
   (* Response cache — path → full HTTP response string.
      Populated during pre-warm, serves cached responses in <0.1ms.
      Thread-safe: reads are lock-free (Hashtbl.find_opt is atomic for
@@ -4990,46 +4685,6 @@ let () =
   else begin
     (* Normal persistent server mode *)
     let env = make_server_env () in
-    (* render-page: render an (unevaluated) SX page/component expression to HTML
-       using the server env, so http-listen handlers can serve interactive SX
-       pages. render-to-html expands components + collects keyword attrs itself;
-       SX handlers can't reach the server env, so this primitive supplies it. *)
-    ignore (env_bind env "render-page" (NativeFn ("render-page", fun args ->
-      match args with
-      | expr :: _ -> String (sx_render_to_html expr env)
-      | _ -> raise (Eval_error "render-page: (expr)"))));
-    (* JIT in the epoch serving mode is OPT-IN via SX_SERVING_JIT=1.
-       Default OFF: this mode is the shared command channel used by every
-       loop's conformance runner, and enabling JIT globally regresses
-       continuation-based guest interpreters (Scheme/Erlang/Prolog/CL: their
-       eval/dispatch cores capture call/cc continuations the stack VM can't
-       escape, and deep AST recursion can miscompile into a non-terminating
-       loop). Guests that are safe declare their interpret-only namespace with
-       `(jit-exclude! "<ns>-*")`; until every guest is validated, the safe
-       default is no JIT here. Opt in (SX_SERVING_JIT=1) for validated
-       workloads — e.g. the content/Smalltalk page server. *)
-    (match Sys.getenv_opt "SX_SERVING_JIT" with
-     | Some ("1" | "true" | "yes" | "on") ->
-       (* Load the SX bytecode compiler (lib/compiler.sx) as `compile` — the
-          native Sx_compiler.compile is an incomplete stub (arity-0 bytecode,
-          params as GLOBAL_GET). http/cli/site modes already load it. *)
-       (_import_env := Some env;
-        let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
-          try Sys.getenv "SX_ROOT" with Not_found ->
-          if Sys.file_exists "/app/spec" then "/app" else Sys.getcwd () in
-        let lib_base = try Sys.getenv "SX_LIB_DIR" with Not_found ->
-          project_dir ^ "/lib" in
-        let compiler_path = lib_base ^ "/compiler.sx" in
-        let compiler_path =
-          if Sys.file_exists compiler_path then compiler_path
-          else if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
-          else compiler_path in
-        try load_library_file compiler_path; rebind_host_extensions env
-        with exn ->
-          Printf.eprintf "[sx-server] WARNING: failed to load compiler.sx for JIT (%s) — JIT disabled\n%!"
-            (Printexc.to_string exn));
-       register_jit_hook env
-     | _ -> ());
     send "(ready)";
     (* Main command loop *)
     try

hosts/ocaml/bin/test_http_client.sh

@@ -1,80 +0,0 @@
-#!/usr/bin/env bash
-# Phase J test — native-only http-request client primitive.
-# Reuses Phase H's http-listen to spin up an echo server, then drives
-# a separate sx_server via the epoch protocol to issue http-request
-# calls and assert response shape + headers + body.
-set -u
-cd "$(dirname "$0")/.."
-
-SRV=_build/default/bin/sx_server.exe
-PORT=${HTTP_CLIENT_TEST_PORT:-8921}
-PASS=0
-FAIL=0
-ok()  { echo "  PASS: $1"; PASS=$((PASS+1)); }
-bad() { echo "  FAIL: $1 — $2"; FAIL=$((FAIL+1)); }
-
-if [ ! -x "$SRV" ]; then
-  echo "build sx_server.exe first (dune build bin/sx_server.exe)"; exit 1
-fi
-
-# /echo echoes method/path/query/body and reflects request X-Custom
-# back as response X-Got; /missing-test → 404.
-H='(begin (define (h req) (if (= (get req "path") "/echo") {:status 200 :headers {"X-Echo" (get req "method") "X-Got" (get (get req "headers") "x-custom")} :body (str "M=" (get req "method") " P=" (get req "path") " Q=" (get req "query") " B=" (get req "body"))} (if (= (get req "path") "/missing-test") {:status 404 :body "nope"} {:status 500 :body "err"}))) (http-listen '"$PORT"' h))'
-ESC=${H//\"/\\\"}
-
-{ printf '(epoch 1)\n(eval "%s")\n' "$ESC"; sleep 60; } | "$SRV" >/tmp/test_http_client_srv.out 2>&1 &
-SVPID=$!
-trap 'kill $SVPID 2>/dev/null; wait 2>/dev/null' EXIT
-
-up=0
-for _ in $(seq 1 50); do
-  curl -s -o /dev/null "http://127.0.0.1:$PORT/echo" 2>/dev/null && { up=1; break; }
-  sleep 0.2
-done
-[ "$up" = 1 ] || { echo "  FAIL: server did not start"; cat /tmp/test_http_client_srv.out; exit 1; }
-
-emit() {
-  # $1 = epoch num, $2 = raw SX form. Wraps in (eval "...") with quotes escaped.
-  local esc=${2//\"/\\\"}
-  printf '(epoch %s)\n(eval "%s")\n' "$1" "$esc"
-}
-
-DRV_OUT=/tmp/test_http_client_drv.out
-{
-  emit 1 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo?x=1" {} ""))) (str "S=" (get r "status") " E=" (get (get r "headers") "x-echo") " B=" (get r "body")))'
-  emit 2 '(let ((r (http-request "POST" "http://127.0.0.1:'"$PORT"'/echo" {} "hello"))) (str "S=" (get r "status") " B=" (get r "body")))'
-  emit 3 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/missing-test" {} ""))) (str "S=" (get r "status") " B=" (get r "body")))'
-  emit 4 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {"X-Custom" "myval"} ""))) (get (get r "headers") "x-got"))'
-  emit 5 '(http-request "GET" "ftp://nope" {} "")'
-  emit 6 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {} ""))) (get r "status"))'
-} | "$SRV" >"$DRV_OUT" 2>&1
-
-# eval results come back as (ok-len N L)\n<body>\n — grep the body content.
-grep -q '^"S=200 E=GET B=M=GET P=/echo Q=x=1 B="$' "$DRV_OUT" \
-  && ok "GET status + echo header + body" \
-  || bad "GET" "$(grep -A1 '^(ok-len 1 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"S=200 B=M=POST P=/echo Q= B=hello"$' "$DRV_OUT" \
-  && ok "POST body roundtrip" \
-  || bad "POST" "$(grep -A1 '^(ok-len 2 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"S=404 B=nope"$' "$DRV_OUT" \
-  && ok "404 status + body" \
-  || bad "404" "$(grep -A1 '^(ok-len 3 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"myval"$' "$DRV_OUT" \
-  && ok "custom request header reaches server" \
-  || bad "custom-header" "$(grep -A1 '^(ok-len 4 ' "$DRV_OUT" | tail -1)"
-
-R5=$(grep '^(error 5 ' "$DRV_OUT" | head -1)
-echo "$R5" | grep -q 'URL must start with http' \
-  && ok "non-http scheme rejected" \
-  || bad "bad-url" "$R5"
-
-# Status is an Integer (200), serialized bare without quotes.
-grep -q '^200$' "$DRV_OUT" \
-  && ok "response status is integer 200" \
-  || bad "status-integer" "$(grep -A1 '^(ok-len 6 ' "$DRV_OUT" | tail -1)"
-
-echo "Results: $PASS passed, $FAIL failed"
-[ "$FAIL" = 0 ]

hosts/ocaml/browser/bundle.sh

@@ -71,11 +71,6 @@ cp "$ROOT/shared/sx/templates/tw-layout.sx" "$DIST/sx/"
 cp "$ROOT/shared/sx/templates/tw-type.sx"   "$DIST/sx/"
 cp "$ROOT/shared/sx/templates/tw.sx"        "$DIST/sx/"
 
-# 9b. Host app components (content-addressed, client-expanded on boosted nav).
-# Listed in the host's data-sx-manifest "boot" array so the client eager-loads
-# them after the web stack — see lib/host/static.sx + sx-platform.js loadWebStack.
-cp "$ROOT/lib/host/sx/relate-picker.sx" "$DIST/sx/"
-
 # 10. Hyperscript
 for f in tokenizer parser compiler runtime integration htmx; do
   cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx"

hosts/ocaml/browser/compile-modules.js

@@ -48,8 +48,6 @@ const SOURCE_MAP = {
   'boot.sx': 'web/boot.sx',
   'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx',
   'text-layout.sx': 'lib/text-layout.sx',
-  // Host app components (content-addressed, client-expanded on boosted nav).
-  'relate-picker.sx': 'lib/host/sx/relate-picker.sx',
 };
 let synced = 0;
 for (const [dist, src] of Object.entries(SOURCE_MAP)) {
@@ -89,8 +87,6 @@ const FILES = [
   'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx',
   'hs-worker.sx', 'hs-prolog.sx',
   'hs-integration.sx', 'hs-htmx.sx',
-  // Host app components — standalone defcomps, no inter-module deps.
-  'relate-picker.sx',
   'boot.sx',
 ];
 

hosts/ocaml/browser/sx-platform.js

@@ -646,18 +646,6 @@
     // Load entry point itself (boot.sx — not a library, just defines + init)
     loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx'));
 
-    // App components: the page's data-sx-manifest "boot" array lists app-specific
-    // modules (e.g. ~relate-picker) to eager-load after the web stack, so their
-    // defcomps are registered before a boosted fragment references them. Loaded
-    // content-addressed, the same as any module.
-    var pageM = loadPageManifest();
-    if (pageM && pageM.boot && pageM.boot.length) {
-      for (var b = 0; b < pageM.boot.length; b++) {
-        var bf = pageM.boot[b];
-        loadBytecodeFile("sx/" + bf) || loadSxFile("sx/" + bf.replace(/\.sxbc$/, '.sx'));
-      }
-    }
-
     if (K.endModuleLoad) K.endModuleLoad();
     var count = Object.keys(_loadedLibs).length + 1; // +1 for entry
     var dt = Math.round(performance.now() - t0);

hosts/ocaml/browser/sx_browser.ml

@@ -73,7 +73,6 @@ let rec value_to_js (v : value) : Js.Unsafe.any =
   | Nil -> Js.Unsafe.inject Js.null
   | Bool b -> Js.Unsafe.inject (Js.bool b)
   | Number n -> Js.Unsafe.inject (Js.number_of_float n)
-  | Integer n -> Js.Unsafe.inject (Js.number_of_float (float_of_int n))
   | String s -> Js.Unsafe.inject (Js.string s)
   | RawHTML s -> Js.Unsafe.inject (Js.string s)
   | Symbol s ->
@@ -330,9 +329,8 @@ let handle_import_suspension request =
   let lib_spec = match request with
     | Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil)
     | _ -> Nil in
-  (* library_loaded_p takes the SPEC and applies library_name_key itself —
-     passing a pre-computed key string double-applies it and crashes. *)
-  if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then
+  let key = Sx_ref.library_name_key lib_spec in
+  if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
     Some Nil  (* Already loaded — resume immediately *)
   else
     None  (* Not loaded — JS platform must fetch it *)

hosts/ocaml/lib/sx_cbor.ml

@@ -15,29 +15,25 @@ exception Cbor_error of string
 
 let write_head buf major v =
   let m = major lsl 5 in
-  (* Width selection + big-endian byte emission via Int64, so the web targets
-     compute identically to native: on js_of_ocaml [int] is 32-bit, so the
-     literal 0x100000000 (2^32) truncates to 0 (sending small values to the
-     8-byte branch) and [v lsr (8*i)] with i>=4 is shift-mod-32. Int64 has the
-     full 64-bit width and well-defined shifts on every target. *)
-  let v64 = Int64.of_int v in
-  let put_be nbytes =
-    for i = nbytes - 1 downto 0 do
-      Buffer.add_char buf
-        (Char.chr (Int64.to_int
-           (Int64.logand (Int64.shift_right_logical v64 (8 * i)) 0xFFL)))
-    done
-  in
   if v < 24 then
     Buffer.add_char buf (Char.chr (m lor v))
   else if v < 0x100 then begin
-    Buffer.add_char buf (Char.chr (m lor 24)); put_be 1
+    Buffer.add_char buf (Char.chr (m lor 24));
+    Buffer.add_char buf (Char.chr v)
   end else if v < 0x10000 then begin
-    Buffer.add_char buf (Char.chr (m lor 25)); put_be 2
-  end else if Int64.compare v64 0x100000000L < 0 then begin
-    Buffer.add_char buf (Char.chr (m lor 26)); put_be 4
+    Buffer.add_char buf (Char.chr (m lor 25));
+    Buffer.add_char buf (Char.chr ((v lsr 8) land 0xFF));
+    Buffer.add_char buf (Char.chr (v land 0xFF))
+  end else if v < 0x100000000 then begin
+    Buffer.add_char buf (Char.chr (m lor 26));
+    for i = 3 downto 0 do
+      Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
+    done
   end else begin
-    Buffer.add_char buf (Char.chr (m lor 27)); put_be 8
+    Buffer.add_char buf (Char.chr (m lor 27));
+    for i = 7 downto 0 do
+      Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
+    done
   end
 
 (* dag-cbor map key order: shorter key first, then bytewise. *)

hosts/ocaml/lib/sx_cid.ml

@@ -32,11 +32,7 @@ let base32_lower (s : string) : string =
     while !bits >= 5 do
       bits := !bits - 5;
       Buffer.add_char buf b32_alpha.[(!acc lsr !bits) land 0x1f]
-    done;
-    (* Keep only the unconsumed low [bits] bits, so [acc] stays tiny (< 2^13).
-       Without this it grows by 8 bits per byte and overflows native [int] on
-       the 32-bit web targets, corrupting the emitted symbols. *)
-    acc := !acc land ((1 lsl !bits) - 1)) s;
+    done) s;
   if !bits > 0 then
     Buffer.add_char buf b32_alpha.[(!acc lsl (5 - !bits)) land 0x1f];
   Buffer.contents buf

hosts/ocaml/lib/sx_ed25519.ml

@@ -68,22 +68,15 @@ let sub (a : bn) (b : bn) : bn =
   norm r
 
 let mul (a : bn) (b : bn) : bn =
-  (* Accumulate in Int64: a limb product is 26+26 = 52 bits, which overflows the
-     web targets' int (32-bit js_of_ocaml / 31-bit wasm_of_ocaml). Int64 is a
-     real 64-bit type on every target, so the carries are exact. *)
   let la = Array.length a and lb = Array.length b in
   let r = Array.make (la + lb) 0 in
-  let maskL = Int64.of_int mask in
   for i = 0 to la - 1 do
-    let carry = ref 0L in
-    let ai = Int64.of_int a.(i) in
+    let carry = ref 0 in
     for j = 0 to lb - 1 do
-      let s = Int64.add (Int64.add (Int64.of_int r.(i + j))
-                           (Int64.mul ai (Int64.of_int b.(j)))) !carry in
-      r.(i + j) <- Int64.to_int (Int64.logand s maskL);
-      carry := Int64.shift_right_logical s bits
+      let s = r.(i + j) + a.(i) * b.(j) + !carry in
+      r.(i + j) <- s land mask; carry := s lsr bits
     done;
-    r.(i + lb) <- r.(i + lb) + Int64.to_int !carry
+    r.(i + lb) <- r.(i + lb) + !carry
   done;
   norm r
 
@@ -116,16 +109,12 @@ let bn_mod (a : bn) (m : bn) : bn =
   end
 
 let div_small (a : bn) (d : int) : bn =
-  (* [rem lsl bits] reaches ~2^34 (rem < d <= 256, bits = 26), past the web
-     targets' int width — accumulate the running remainder in Int64. *)
   let la = Array.length a in
   let q = Array.make la 0 in
-  let rem = ref 0L in
-  let dL = Int64.of_int d in
+  let rem = ref 0 in
   for i = la - 1 downto 0 do
-    let cur = Int64.logor (Int64.shift_left !rem bits) (Int64.of_int a.(i)) in
-    q.(i) <- Int64.to_int (Int64.div cur dL);
-    rem := Int64.rem cur dL
+    let cur = (!rem lsl bits) lor a.(i) in
+    q.(i) <- cur / d; rem := cur mod d
   done;
   norm q
 

hosts/ocaml/lib/sx_persist_store.ml

@@ -1,293 +0,0 @@
-(* sx_persist_store — host durable-storage adapter for lib/persist.
-   Production twin of `persist/serve` (lib/persist/durable.sx): it answers the
-   same `persist/...` IO ops, but backs them with real on-disk storage so writes
-   survive a process restart. Stateless-on-disk: every op reads/writes the
-   filesystem directly, so a fresh process recovers state with no warm-up — the
-   log on disk IS the state.
-
-   On-disk layout under the root dir (default ./persist-data, or $SX_PERSIST_DIR):
-     streams/<hex(stream)>.log   append-only, one SX-serialized event per line
-     streams/<hex(stream)>.seq   per-stream monotonic high-water counter (int)
-     kv/<hex(key)>               one SX-serialized value per key
-
-   Invariants honoured (see plans/persist-on-sx.md Blocker spec):
-   1. last-seq is a per-stream monotonic counter stored in .seq, SEPARATE from
-      the rows — it keeps climbing across truncate, so a compacted stream never
-      reassigns a seq.
-   2. append never renumbers — the event already carries its :seq (log.sx does
-      last-seq+1); the host only bumps the high-water mark to max(hw, seq).
-   3. read returns surviving events in append order with :seq intact.
-   4. streams is the set of streams that ever had an append — keyed off the .seq
-      file, which truncate never deletes, so it survives full compaction.
-   5. values round-trip structurally via the SX serializer/parser. *)
-
-open Sx_types
-
-(* ---- root dir ---------------------------------------------------------- *)
-
-let _root : string option ref = ref None
-
-let set_root dir = _root := Some dir
-
-let root_dir () =
-  match !_root with
-  | Some d -> d
-  | None -> (try Sys.getenv "SX_PERSIST_DIR" with Not_found -> "persist-data")
-
-(* ---- filesystem helpers ------------------------------------------------ *)
-
-let rec ensure_dir dir =
-  if dir = "" || dir = "." || dir = "/" || Sys.file_exists dir then ()
-  else begin
-    ensure_dir (Filename.dirname dir);
-    (try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
-  end
-
-let streams_dir () = Filename.concat (root_dir ()) "streams"
-let kv_dir () = Filename.concat (root_dir ()) "kv"
-let blobs_dir () = Filename.concat (root_dir ()) "blobs"
-
-let read_file path =
-  let ic = open_in_bin path in
-  let n = in_channel_length ic in
-  let s = really_input_string ic n in
-  close_in ic;
-  s
-
-(* Atomic write: temp file in the same dir then rename over the target. *)
-let write_file_atomic path contents =
-  ensure_dir (Filename.dirname path);
-  let tmp = path ^ ".tmp" in
-  let oc = open_out_bin tmp in
-  output_string oc contents;
-  flush oc;
-  close_out oc;
-  Sys.rename tmp path
-
-let append_line path line =
-  ensure_dir (Filename.dirname path);
-  let oc = open_out_gen [Open_append; Open_creat; Open_wronly] 0o644 path in
-  output_string oc line;
-  output_char oc '\n';
-  close_out oc
-
-(* ---- name <-> filename (hex, reversible, fs-safe) ---------------------- *)
-
-let hex_encode s =
-  let b = Buffer.create (String.length s * 2) in
-  String.iter (fun c -> Buffer.add_string b (Printf.sprintf "%02x" (Char.code c))) s;
-  Buffer.contents b
-
-let hex_decode s =
-  let n = String.length s / 2 in
-  String.init n (fun i -> Char.chr (int_of_string ("0x" ^ String.sub s (i * 2) 2)))
-
-let stream_log stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".log")
-let stream_seq stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".seq")
-let kv_path key = Filename.concat (kv_dir ()) (hex_encode key)
-
-(* ---- value <-> SX text (round-trips through Sx_parser) ----------------- *)
-
-let escape_str s =
-  let len = String.length s in
-  let buf = Buffer.create (len + 16) in
-  for i = 0 to len - 1 do
-    match s.[i] with
-    | '"'  -> Buffer.add_string buf "\\\""
-    | '\\' -> Buffer.add_string buf "\\\\"
-    | '\n' -> Buffer.add_string buf "\\n"
-    | '\r' -> Buffer.add_string buf "\\r"
-    | '\t' -> Buffer.add_string buf "\\t"
-    | c    -> Buffer.add_char buf c
-  done;
-  Buffer.contents buf
-
-let rec serialize = function
-  | Nil -> "nil"
-  | Bool true -> "true"
-  | Bool false -> "false"
-  | Integer n -> string_of_int n
-  | Number n -> format_number n
-  | String s -> "\"" ^ escape_str s ^ "\""
-  | Symbol s -> "(quote " ^ s ^ ")"
-  | Keyword k -> ":" ^ k
-  | List items | ListRef { contents = items } ->
-    "(list" ^ (List.fold_left (fun acc v -> acc ^ " " ^ serialize v) "" items) ^ ")"
-  | Dict d ->
-    let pairs = Hashtbl.fold (fun k v acc ->
-      (Printf.sprintf ":%s %s" k (serialize v)) :: acc) d [] in
-    "{" ^ String.concat " " (List.sort String.compare pairs) ^ "}"
-  | _ -> "nil"
-
-(* Parse one serialized value back. Empty / blank -> Nil. *)
-let rec deserialize line =
-  let line = String.trim line in
-  if line = "" then Nil
-  else match Sx_parser.parse_all line with
-    | v :: _ -> eval_quote_lists v
-    | [] -> Nil
-
-(* serialize emits lists as `(list ...)` and symbols as `(quote s)` so the
-   parser yields data, not a call — but the parser leaves those as AST. Walk
-   the parsed AST and collapse `(list ...)`/`(quote s)` back to values. *)
-and eval_quote_lists v =
-  match v with
-  | List (Symbol "quote" :: x :: []) -> x
-  | List (Symbol "list" :: rest) -> List (List.map eval_quote_lists rest)
-  | List items -> List (List.map eval_quote_lists items)
-  | ListRef { contents = items } -> List (List.map eval_quote_lists items)
-  | Dict d ->
-    let d' = Hashtbl.create (Hashtbl.length d) in
-    Hashtbl.iter (fun k v -> Hashtbl.replace d' k (eval_quote_lists v)) d;
-    Dict d'
-  | other -> other
-
-(* ---- seq counter ------------------------------------------------------- *)
-
-let read_seq stream =
-  let p = stream_seq stream in
-  if Sys.file_exists p then (try int_of_string (String.trim (read_file p)) with _ -> 0)
-  else 0
-
-let write_seq stream n = write_file_atomic (stream_seq stream) (string_of_int n)
-
-let value_to_int = function
-  | Integer n -> n
-  | Number n -> int_of_float n
-  | _ -> 0
-
-let event_seq ev =
-  match ev with
-  | Dict d -> (match Hashtbl.find_opt d "seq" with Some v -> value_to_int v | None -> 0)
-  | _ -> 0
-
-(* ---- ops --------------------------------------------------------------- *)
-
-let do_append stream ev =
-  ensure_dir (streams_dir ());
-  (* bump the monotonic high-water mark; create .seq on first append so the
-     stream shows up in `streams` and survives later truncation. *)
-  let hw = read_seq stream in
-  let s = event_seq ev in
-  write_seq stream (max hw s);
-  append_line (stream_log stream) (serialize ev)
-
-let do_read stream =
-  let p = stream_log stream in
-  if not (Sys.file_exists p) then List []
-  else begin
-    let content = read_file p in
-    let lines = String.split_on_char '\n' content in
-    let evs = List.filter_map (fun l ->
-      if String.trim l = "" then None else Some (deserialize l)) lines in
-    List evs
-  end
-
-let do_last_seq stream = Number (float_of_int (read_seq stream))
-
-let list_dir_suffix dir suffix =
-  if not (Sys.file_exists dir) then []
-  else
-    Array.to_list (Sys.readdir dir)
-    |> List.filter (fun f -> Filename.check_suffix f suffix)
-    |> List.map (fun f -> hex_decode (Filename.chop_suffix f suffix))
-    |> List.sort String.compare
-
-let do_streams () = List (List.map (fun s -> String s) (list_dir_suffix (streams_dir ()) ".seq"))
-
-(* drop events with seq <= n; the .seq high-water counter is untouched. *)
-let do_truncate stream n =
-  let p = stream_log stream in
-  if Sys.file_exists p then begin
-    let evs = match do_read stream with List l -> l | _ -> [] in
-    let kept = List.filter (fun ev -> event_seq ev > n) evs in
-    let body = String.concat "" (List.map (fun ev -> serialize ev ^ "\n") kept) in
-    write_file_atomic p body
-  end
-
-let do_kv_get key =
-  let p = kv_path key in
-  if Sys.file_exists p then deserialize (read_file p) else Nil
-
-let do_kv_put key v =
-  ensure_dir (kv_dir ());
-  write_file_atomic (kv_path key) (serialize v)
-
-let do_kv_delete key =
-  let p = kv_path key in
-  if Sys.file_exists p then (try Sys.remove p with _ -> ())
-
-let do_kv_has key = Bool (Sys.file_exists (kv_path key))
-
-let do_kv_keys () =
-  if not (Sys.file_exists (kv_dir ())) then List []
-  else
-    List (
-      Array.to_list (Sys.readdir (kv_dir ()))
-      |> List.map hex_decode
-      |> List.sort String.compare
-      |> List.map (fun s -> String s))
-
-(* ---- blob store (content-addressed) ------------------------------------ *)
-(* Same pattern as the persist ops, but a SEPARATE adapter: large objects live
-   in a content-addressed directory keyed by a CIDv1 (raw codec, sha2-256).
-   persist only ever stores the returned ref ({:cid :size :mime}), never bytes.
-   blob/put is idempotent — identical bytes hash to the same cid + same file. *)
-
-let codec_raw = 0x55
-
-let blob_cid bytes =
-  let digest = Sx_cid.unhex (Sx_sha2.sha256_hex bytes) in
-  Sx_cid.cidv1 codec_raw (Sx_cid.multihash Sx_cid.mh_sha2_256 digest)
-
-let blob_path cid = Filename.concat (blobs_dir ()) cid
-
-let do_blob_put bytes =
-  let cid = blob_cid bytes in
-  let p = blob_path cid in
-  if not (Sys.file_exists p) then write_file_atomic p bytes;
-  String cid
-
-let do_blob_get cid =
-  let p = blob_path cid in
-  if Sys.file_exists p then String (read_file p) else Nil
-
-let do_blob_has cid = Bool (Sys.file_exists (blob_path cid))
-
-(* ---- dispatch ---------------------------------------------------------- *)
-
-let arglist = function
-  | List l | ListRef { contents = l } -> l
-  | Nil -> []
-  | v -> [v]
-
-(* Returns Some response if op is a persist op this store owns, None otherwise. *)
-let handle_op op args =
-  let a = arglist args in
-  let str = function String s -> s | v -> value_to_string v in
-  match op with
-  | "persist/append" ->
-    (match a with stream :: ev :: _ -> do_append (str stream) ev | _ -> ()); Some Nil
-  | "persist/read" ->
-    (match a with stream :: _ -> Some (do_read (str stream)) | _ -> Some (List []))
-  | "persist/last-seq" ->
-    (match a with stream :: _ -> Some (do_last_seq (str stream)) | _ -> Some (Number 0.0))
-  | "persist/streams" -> Some (do_streams ())
-  | "persist/truncate" ->
-    (match a with stream :: n :: _ -> do_truncate (str stream) (value_to_int n) | _ -> ()); Some Nil
-  | "persist/kv-get" ->
-    (match a with key :: _ -> Some (do_kv_get (str key)) | _ -> Some Nil)
-  | "persist/kv-put" ->
-    (match a with key :: v :: _ -> do_kv_put (str key) v | _ -> ()); Some Nil
-  | "persist/kv-delete" ->
-    (match a with key :: _ -> do_kv_delete (str key) | _ -> ()); Some Nil
-  | "persist/kv-has?" ->
-    (match a with key :: _ -> Some (do_kv_has (str key)) | _ -> Some (Bool false))
-  | "persist/kv-keys" -> Some (do_kv_keys ())
-  | "blob/put" ->
-    (match a with bytes :: _ -> Some (do_blob_put (str bytes)) | _ -> Some Nil)
-  | "blob/get" ->
-    (match a with cid :: _ -> Some (do_blob_get (str cid)) | _ -> Some Nil)
-  | "blob/has?" ->
-    (match a with cid :: _ -> Some (do_blob_has (str cid)) | _ -> Some (Bool false))
-  | _ -> None

hosts/ocaml/lib/sx_primitives.ml

@@ -4168,38 +4168,6 @@ let () =
     ) Sx_types.jit_cache_queue;
     Queue.clear Sx_types.jit_cache_queue;
     Nil);
-  register "jit-exclude!" (fun args ->
-    (* Mark function names as interpret-only (never JIT-compiled). A guest
-       interpreter calls this for its continuation-using dispatch core.
-       Accepts string/symbol names; a trailing "*" makes it a namespace prefix
-       (e.g. "er-*" excludes every function whose name starts with "er-") —
-       the robust way to declare a whole guest interpreter core. *)
-    List.iter (fun a ->
-      match a with
-      | String n | Symbol n ->
-        let len = String.length n in
-        if len > 0 && n.[len - 1] = '*' then begin
-          let prefix = String.sub n 0 (len - 1) in
-          if not (List.mem prefix !Sx_types.jit_excluded_prefixes) then
-            Sx_types.jit_excluded_prefixes := prefix :: !Sx_types.jit_excluded_prefixes
-        end else
-          Hashtbl.replace Sx_types.jit_excluded n ()
-      | _ -> ()) args;
-    Nil);
-  register "jit-excluded?" (fun args ->
-    match args with
-    | [String n] | [Symbol n] -> Bool (Sx_types.jit_name_excluded n)
-    | _ -> Bool false);
-  register "jit-exclude-callers-of!" (fun args ->
-    (* Register call/cc-establishing forms (e.g. cl-restart-case). Any function
-       whose bytecode references one of these is itself interpret-only — JIT
-       would force the form into a nested cek-run where its continuation can't
-       escape. A guest declares its condition-system / escaping forms here. *)
-    List.iter (fun a ->
-      match a with
-      | String n | Symbol n -> Hashtbl.replace Sx_types.jit_excluded_caller_names n ()
-      | _ -> ()) args;
-    Nil);
   register "jit-reset-counters!" (fun _args ->
     Sx_types.jit_compiled_count := 0;
     Sx_types.jit_skipped_count := 0;

hosts/ocaml/lib/sx_ref.ml

@@ -404,7 +404,7 @@ and library_loaded_p spec =
 
 (* library-exports *)
 and library_exports spec =
-  (let entry = (get (_library_registry_) ((library_name_key (spec)))) in (if sx_truthy (entry) then (get (entry) ((String "exports"))) else (Dict (Hashtbl.create 0))))
+  (get ((get (_library_registry_) ((library_name_key (spec))))) ((String "exports")))
 
 (* register-library *)
 and register_library spec exports =

hosts/ocaml/lib/sx_runtime.ml

@@ -17,19 +17,11 @@ let rec _fast_eq a b =
   | Number x, Number y -> x = y
   | Integer x, Number y -> float_of_int x = y
   | Number x, Integer y -> x = float_of_int y
-  (* Exact rationals — must match the "=" primitive (safe_eq). Cross-multiply
-     for rational/rational; coerce for rational/int and rational/float. *)
-  | Rational (an, ad), Rational (bn, bd) -> an * bd = bn * ad
-  | Rational (n, d), Integer y -> n = y * d
-  | Integer x, Rational (n, d) -> x * d = n
-  | Rational (n, d), Number y -> float_of_int n /. float_of_int d = y
-  | Number x, Rational (n, d) -> x = float_of_int n /. float_of_int d
   | Bool x, Bool y -> x = y
   | Nil, Nil -> true
   | Symbol x, Symbol y -> x = y
   | Keyword x, Keyword y -> x = y
-  | (List la | ListRef { contents = la }),
-    (List lb | ListRef { contents = lb }) ->
+  | List la, List lb ->
     (try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false)
   | _ -> false
 

hosts/ocaml/lib/sx_sha2.ml

@@ -3,40 +3,37 @@
     No C stubs, no external deps. Used by the fed-sx host primitives
     [crypto-sha256] / [crypto-sha512]. Reference: FIPS 180-4. *)
 
-(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words via Int32, NOT native int.
-   On the web targets the kernel is compiled by js_of_ocaml (32-bit int) and
-   wasm_of_ocaml (31-bit int), where native [int] silently truncates the 32-bit
-   round words — producing WRONG digests (and, downstream, bad CIDs and a
-   Char.chr crash at kernel init). Int32 has well-defined wrap-around mod 2^32 on
-   every target, so this matches the 63-bit native build exactly. ---- *)
+(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words held in native int,
+   masked to 32 bits after every arithmetic op. ---- *)
+
+let mask32 = 0xFFFFFFFF
 
 let k256 = [|
-  0x428a2f98l; 0x71374491l; 0xb5c0fbcfl; 0xe9b5dba5l;
-  0x3956c25bl; 0x59f111f1l; 0x923f82a4l; 0xab1c5ed5l;
-  0xd807aa98l; 0x12835b01l; 0x243185bel; 0x550c7dc3l;
-  0x72be5d74l; 0x80deb1fel; 0x9bdc06a7l; 0xc19bf174l;
-  0xe49b69c1l; 0xefbe4786l; 0x0fc19dc6l; 0x240ca1ccl;
-  0x2de92c6fl; 0x4a7484aal; 0x5cb0a9dcl; 0x76f988dal;
-  0x983e5152l; 0xa831c66dl; 0xb00327c8l; 0xbf597fc7l;
-  0xc6e00bf3l; 0xd5a79147l; 0x06ca6351l; 0x14292967l;
-  0x27b70a85l; 0x2e1b2138l; 0x4d2c6dfcl; 0x53380d13l;
-  0x650a7354l; 0x766a0abbl; 0x81c2c92el; 0x92722c85l;
-  0xa2bfe8a1l; 0xa81a664bl; 0xc24b8b70l; 0xc76c51a3l;
-  0xd192e819l; 0xd6990624l; 0xf40e3585l; 0x106aa070l;
-  0x19a4c116l; 0x1e376c08l; 0x2748774cl; 0x34b0bcb5l;
-  0x391c0cb3l; 0x4ed8aa4al; 0x5b9cca4fl; 0x682e6ff3l;
-  0x748f82eel; 0x78a5636fl; 0x84c87814l; 0x8cc70208l;
-  0x90befffal; 0xa4506cebl; 0xbef9a3f7l; 0xc67178f2l |]
+  0x428a2f98; 0x71374491; 0xb5c0fbcf; 0xe9b5dba5;
+  0x3956c25b; 0x59f111f1; 0x923f82a4; 0xab1c5ed5;
+  0xd807aa98; 0x12835b01; 0x243185be; 0x550c7dc3;
+  0x72be5d74; 0x80deb1fe; 0x9bdc06a7; 0xc19bf174;
+  0xe49b69c1; 0xefbe4786; 0x0fc19dc6; 0x240ca1cc;
+  0x2de92c6f; 0x4a7484aa; 0x5cb0a9dc; 0x76f988da;
+  0x983e5152; 0xa831c66d; 0xb00327c8; 0xbf597fc7;
+  0xc6e00bf3; 0xd5a79147; 0x06ca6351; 0x14292967;
+  0x27b70a85; 0x2e1b2138; 0x4d2c6dfc; 0x53380d13;
+  0x650a7354; 0x766a0abb; 0x81c2c92e; 0x92722c85;
+  0xa2bfe8a1; 0xa81a664b; 0xc24b8b70; 0xc76c51a3;
+  0xd192e819; 0xd6990624; 0xf40e3585; 0x106aa070;
+  0x19a4c116; 0x1e376c08; 0x2748774c; 0x34b0bcb5;
+  0x391c0cb3; 0x4ed8aa4a; 0x5b9cca4f; 0x682e6ff3;
+  0x748f82ee; 0x78a5636f; 0x84c87814; 0x8cc70208;
+  0x90befffa; 0xa4506ceb; 0xbef9a3f7; 0xc67178f2 |]
 
-let rotr32 (x : int32) (n : int) : int32 =
-  Int32.logor (Int32.shift_right_logical x n) (Int32.shift_left x (32 - n))
+let rotr32 x n = ((x lsr n) lor (x lsl (32 - n))) land mask32
 
 let sha256_hex (msg : string) : string =
-  let h = [| 0x6a09e667l; 0xbb67ae85l; 0x3c6ef372l; 0xa54ff53al;
-             0x510e527fl; 0x9b05688cl; 0x1f83d9abl; 0x5be0cd19l |] in
+  let h = [| 0x6a09e667; 0xbb67ae85; 0x3c6ef372; 0xa54ff53a;
+             0x510e527f; 0x9b05688c; 0x1f83d9ab; 0x5be0cd19 |] in
   let len = String.length msg in
   (* Padded length: multiple of 64 bytes. *)
-  let bitlen = Int64.mul (Int64.of_int len) 8L in
+  let bitlen = len * 8 in
   let padlen =
     let r = (len + 1) mod 64 in
     if r <= 56 then 56 - r else 120 - r
@@ -45,79 +42,60 @@ let sha256_hex (msg : string) : string =
   let buf = Bytes.make total '\000' in
   Bytes.blit_string msg 0 buf 0 len;
   Bytes.set buf len '\x80';
-  (* 64-bit big-endian bit length. Int64 shifts so the high bytes (shift >= 32)
-     are correct on the 32-bit web targets — native int `lsr 32` is shift-mod-32
-     on js_of_ocaml and would leak the low length byte into a higher word. *)
+  (* 64-bit big-endian bit length (we cap at OCaml int range). *)
   for i = 0 to 7 do
     Bytes.set buf (total - 1 - i)
-      (Char.chr (Int64.to_int
-         (Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL)))
+      (Char.chr ((bitlen lsr (8 * i)) land 0xFF))
   done;
-  let byte i = Int32.of_int (Char.code (Bytes.get buf i)) in
-  let w = Array.make 64 0l in
+  let w = Array.make 64 0 in
   let nblocks = total / 64 in
   for b = 0 to nblocks - 1 do
     let base = b * 64 in
     for t = 0 to 15 do
       let o = base + t * 4 in
       w.(t) <-
-        Int32.logor
-          (Int32.logor
-             (Int32.shift_left (byte o) 24)
-             (Int32.shift_left (byte (o + 1)) 16))
-          (Int32.logor
-             (Int32.shift_left (byte (o + 2)) 8)
-             (byte (o + 3)))
+        (Char.code (Bytes.get buf o) lsl 24)
+        lor (Char.code (Bytes.get buf (o + 1)) lsl 16)
+        lor (Char.code (Bytes.get buf (o + 2)) lsl 8)
+        lor (Char.code (Bytes.get buf (o + 3)))
     done;
     for t = 16 to 63 do
       let s0 =
-        Int32.logxor
-          (Int32.logxor (rotr32 w.(t - 15) 7) (rotr32 w.(t - 15) 18))
-          (Int32.shift_right_logical w.(t - 15) 3) in
+        (rotr32 w.(t - 15) 7) lxor (rotr32 w.(t - 15) 18)
+        lxor (w.(t - 15) lsr 3) in
       let s1 =
-        Int32.logxor
-          (Int32.logxor (rotr32 w.(t - 2) 17) (rotr32 w.(t - 2) 19))
-          (Int32.shift_right_logical w.(t - 2) 10) in
-      w.(t) <-
-        Int32.add (Int32.add w.(t - 16) s0) (Int32.add w.(t - 7) s1)
+        (rotr32 w.(t - 2) 17) lxor (rotr32 w.(t - 2) 19)
+        lxor (w.(t - 2) lsr 10) in
+      w.(t) <- (w.(t - 16) + s0 + w.(t - 7) + s1) land mask32
     done;
     let a = ref h.(0) and bb = ref h.(1) and c = ref h.(2)
     and d = ref h.(3) and e = ref h.(4) and f = ref h.(5)
     and g = ref h.(6) and hh = ref h.(7) in
     for t = 0 to 63 do
       let s1 =
-        Int32.logxor
-          (Int32.logxor (rotr32 !e 6) (rotr32 !e 11)) (rotr32 !e 25) in
-      let ch =
-        Int32.logxor (Int32.logand !e !f)
-          (Int32.logand (Int32.lognot !e) !g) in
-      let t1 =
-        Int32.add
-          (Int32.add (Int32.add !hh s1) (Int32.add ch k256.(t))) w.(t) in
+        (rotr32 !e 6) lxor (rotr32 !e 11) lxor (rotr32 !e 25) in
+      let ch = (!e land !f) lxor ((lnot !e land mask32) land !g) in
+      let t1 = (!hh + s1 + ch + k256.(t) + w.(t)) land mask32 in
       let s0 =
-        Int32.logxor
-          (Int32.logxor (rotr32 !a 2) (rotr32 !a 13)) (rotr32 !a 22) in
-      let maj =
-        Int32.logxor
-          (Int32.logxor (Int32.logand !a !bb) (Int32.logand !a !c))
-          (Int32.logand !bb !c) in
-      let t2 = Int32.add s0 maj in
+        (rotr32 !a 2) lxor (rotr32 !a 13) lxor (rotr32 !a 22) in
+      let maj = (!a land !bb) lxor (!a land !c) lxor (!bb land !c) in
+      let t2 = (s0 + maj) land mask32 in
       hh := !g; g := !f; f := !e;
-      e := Int32.add !d t1;
+      e := (!d + t1) land mask32;
       d := !c; c := !bb; bb := !a;
-      a := Int32.add t1 t2
+      a := (t1 + t2) land mask32
     done;
-    h.(0) <- Int32.add h.(0) !a;
-    h.(1) <- Int32.add h.(1) !bb;
-    h.(2) <- Int32.add h.(2) !c;
-    h.(3) <- Int32.add h.(3) !d;
-    h.(4) <- Int32.add h.(4) !e;
-    h.(5) <- Int32.add h.(5) !f;
-    h.(6) <- Int32.add h.(6) !g;
-    h.(7) <- Int32.add h.(7) !hh
+    h.(0) <- (h.(0) + !a) land mask32;
+    h.(1) <- (h.(1) + !bb) land mask32;
+    h.(2) <- (h.(2) + !c) land mask32;
+    h.(3) <- (h.(3) + !d) land mask32;
+    h.(4) <- (h.(4) + !e) land mask32;
+    h.(5) <- (h.(5) + !f) land mask32;
+    h.(6) <- (h.(6) + !g) land mask32;
+    h.(7) <- (h.(7) + !hh) land mask32
   done;
   let out = Buffer.create 64 in
-  Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08lx" x)) h;
+  Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08x" x)) h;
   Buffer.contents out
 
 (* ---- SHA-512 (FIPS 180-4 §6.4). 64-bit words via Int64.
@@ -168,7 +146,7 @@ let sha512_hex (msg : string) : string =
              0x510e527fade682d1L; 0x9b05688c2b3e6c1fL;
              0x1f83d9abfb41bd6bL; 0x5be0cd19137e2179L |] in
   let len = String.length msg in
-  let bitlen = Int64.mul (Int64.of_int len) 8L in
+  let bitlen = len * 8 in
   (* Pad to a multiple of 128 bytes; 16-byte big-endian length. *)
   let padlen =
     let r = (len + 1) mod 128 in
@@ -178,12 +156,9 @@ let sha512_hex (msg : string) : string =
   let buf = Bytes.make total '\000' in
   Bytes.blit_string msg 0 buf 0 len;
   Bytes.set buf len '\x80';
-  (* Low 64 bits of the bit length (high 64 stay 0). Int64 shifts so the bytes
-     at shift >= 32 are correct on the 32-bit web targets (js shift-mod-32). *)
   for i = 0 to 7 do
     Bytes.set buf (total - 1 - i)
-      (Char.chr (Int64.to_int
-         (Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL)))
+      (Char.chr ((bitlen lsr (8 * i)) land 0xFF))
   done;
   let w = Array.make 80 0L in
   let nblocks = total / 128 in

hosts/ocaml/lib/sx_types.ml

@@ -470,52 +470,6 @@ let jit_compiled_count = ref 0
 let jit_skipped_count = ref 0
 let jit_threshold_skipped_count = ref 0
 
-(** Runtime, data-driven JIT exclusion set. Names added here are never
-    JIT-compiled — they run on the CEK interpreter instead.
-
-    This is how a guest interpreter declares its *interpret-only* functions:
-    those that capture or invoke first-class continuations (e.g. Smalltalk's
-    [call/cc]-based non-local return [^expr], or block escape). The stack VM
-    cannot transfer control through a CEK continuation, so a JIT-compiled
-    frame on the OCaml/VM stack between a [call/cc] and its [(k v)] invocation
-    would either fail at runtime or (worse) re-run with duplicated side
-    effects. Marking the dispatch core interpret-only keeps those functions on
-    the CEK while pure helpers still JIT.
-
-    Populated from SX via the [jit-exclude!] primitive (see sx_primitives).
-    Consulted in [Sx_vm.jit_compile_lambda], so it covers BOTH JIT entry
-    points: the CEK call hook and the in-VM tiered-compilation path. *)
-let jit_excluded : (string, unit) Hashtbl.t = Hashtbl.create 64
-
-(** Namespace-prefix exclusions. A guest interpreter declares its whole
-    function namespace interpret-only with one entry (e.g. ["er-"], ["scm-"]),
-    which is far more robust than enumerating every function — a name-list
-    misses functions in extra files (the erlang VM dispatcher, etc.) and
-    silently regresses. Set via [jit-exclude!] with a trailing ["*"]
-    (e.g. [(jit-exclude! "er-*")]). Checked via [jit_name_excluded]. *)
-let jit_excluded_prefixes : string list ref = ref []
-
-(** True if [name] is excluded from JIT — by exact name or by namespace prefix. *)
-let jit_name_excluded name =
-  Hashtbl.mem jit_excluded name
-  || List.exists (fun p ->
-       String.length name >= String.length p
-       && String.sub name 0 (String.length p) = p) !jit_excluded_prefixes
-
-(** Names of functions that ESTABLISH an escaping continuation via call/cc
-    (e.g. Common-Lisp's [cl-restart-case] / [cl-handler-case] — the condition
-    system). Any SX function that *calls* one of these is itself unsafe to JIT:
-    JIT-compiling the caller forces the call/cc-wrapping form to run in a nested
-    cek-run, where invoking the captured continuation runs-to-completion-and-
-    returns instead of escaping — so a restart/non-local exit silently fails
-    and the body falls through (observed as result accumulation / no-abort).
-
-    These callers are NOT a fixed namespace (they are arbitrary user/test code),
-    so they cannot be prefix-excluded. Instead a guest declares its escaping
-    forms here (via [jit-exclude-callers-of!]) and [jit_compile_lambda] skips
-    any function whose constant pool references one of them. *)
-let jit_excluded_caller_names : (string, unit) Hashtbl.t = Hashtbl.create 16
-
 (** {2 JIT cache LRU eviction — Phase 2}
 
     Once a lambda crosses the threshold, its [l_compiled] slot is filled.

hosts/ocaml/lib/sx_vm.ml

@@ -336,51 +336,30 @@ and call_closure_reuse cl args =
     push_closure_frame vm cl args;
     let saved_frames = List.tl vm.frames in
     vm.frames <- [List.hd vm.frames];
-    let result =
-      (try run vm;
-        (* Normal completion: result sits at the top of the stack.
-           OP_RETURN normally leaves sp = saved_sp + 1, but the
-           bytecode-exhausted path (or a callee that returns a closure whose
-           own RETURN leaves extra stack residue) can leave sp inconsistent.
-           Read the result at the expected slot. *)
-        if vm.sp > saved_sp then vm.stack.(vm.sp - 1) else Nil
+    (try run vm
      with
-       | VmSuspended (req, _) as e ->
-         (match !Sx_types._cek_io_resolver with
-          | Some resolver ->
-            (* Serving path: a `perform` fired inside this HO-primitive
-               callback (map/filter/reduce/for-each/…). The primitive's native
-               OCaml loop sits between us and the resume point, so we CANNOT
-               unwind it and resume later (the loop state would be lost and the
-               remaining elements dropped — corrupting the stack so the next
-               CALL_PRIM sees wrong args). Instead resolve the callback's IO
-               inline and run it to completion right here, returning its value
-               to the native loop exactly as a non-suspending callback would.
-               reuse_stack is isolated so an outer suspension's saved
-               continuations aren't consumed by this nested resume. *)
-            let saved_reuse = vm.reuse_stack in
-            vm.reuse_stack <- [];
-            let rec settle req =
-              let r = resolver req Nil in
-              (try resume_vm vm r
-               with VmSuspended (req2, _) -> settle req2)
-            in
-            let cb = settle req in
-            vm.reuse_stack <- saved_reuse;
-            cb
-          | None ->
-            (* CEK-driven path (no synchronous resolver): preserve the existing
-               behaviour — save the caller's continuation on the reuse stack and
-               re-raise so resume_vm restores it after the callback finishes.
-               DON'T merge frames — that corrupts the frame chain. *)
+     | VmSuspended _ as e ->
+       (* IO suspension: save the caller's continuation on the reuse stack.
+          DON'T merge frames — that corrupts the frame chain with nested
+          closures. On resume, restore_reuse in resume_vm processes these
+          in innermost-first order after the callback finishes. *)
        vm.reuse_stack <- (saved_frames, saved_sp) :: vm.reuse_stack;
-            raise e)
+       raise e
      | e ->
        vm.frames <- saved_frames;
        vm.sp <- saved_sp;
-         raise e)
-    in
+       raise e);
     vm.frames <- saved_frames;
+    (* Snapshot/restore sp around the popped result.
+       OP_RETURN normally leaves sp = saved_sp + 1, but the bytecode-exhausted
+       path (or a callee that returns a closure whose own RETURN leaves extra
+       stack residue) can leave sp inconsistent. Read the result at the
+       expected slot and reset sp explicitly so the parent frame's
+       intermediate values are not corrupted. *)
+    let result =
+      if vm.sp > saved_sp then vm.stack.(vm.sp - 1)
+      else Nil
+    in
     vm.sp <- saved_sp;
     result
   | None ->
@@ -829,31 +808,14 @@ and run vm =
           let b = pop vm and a = pop vm in
           push vm (match a, b with
             | Integer x, Integer y when y <> 0 && x mod y = 0 -> Integer (x / y)
-            (* Non-divisible Integer/Integer must delegate to the "/" primitive:
-               it returns an exact Rational (e.g. 1/2), matching CEK semantics.
-               Inlining float division here (0.5) diverges from the interpreter
-               and breaks numeric equality against rational results. *)
+            | Integer x, Integer y -> Number (float_of_int x /. float_of_int y)
             | Number x, Number y -> Number (x /. y)
             | Integer x, Number y -> Number (float_of_int x /. y)
             | Number x, Integer y -> Number (x /. float_of_int y)
             | _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
         | 164 (* OP_EQ *) ->
           let b = pop vm and a = pop vm in
-          (* Trivial scalar cases inline; everything else (Rational, Dict,
-             Record, Vector, ListRef, nested lists) delegates to the "="
-             primitive so VM equality matches CEK exactly. _fast_eq is a
-             stripped-down subset and must not be the source of truth here. *)
-          push vm (match a, b with
-            | Integer x, Integer y -> Bool (x = y)
-            | Number x, Number y -> Bool (x = y)
-            | Integer x, Number y -> Bool (float_of_int x = y)
-            | Number x, Integer y -> Bool (x = float_of_int y)
-            | String x, String y -> Bool (x = y)
-            | Bool x, Bool y -> Bool (x = y)
-            | Symbol x, Symbol y -> Bool (x = y)
-            | Keyword x, Keyword y -> Bool (x = y)
-            | Nil, Nil -> Bool true
-            | _ -> (Hashtbl.find Sx_primitives.primitives "=") [a; b])
+          push vm (Bool (Sx_runtime._fast_eq a b))
         | 165 (* OP_LT *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
@@ -959,17 +921,7 @@ and run vm =
 
     After the callback finishes, restores any call_closure_reuse
     continuations saved on vm.reuse_stack (innermost first). *)
-and resume_vm vm result =
-  (* The resumed execution runs on [vm]; HO primitives (map/filter/…) called
-     during the resume reach for [!_active_vm] to run their callbacks on the
-     same stack. call_closure restored [_active_vm] to the *caller* when the
-     original VmSuspended unwound through it, so without re-asserting it here
-     the resumed run's callbacks land on the wrong VM (or allocate a fresh
-     one), corrupting the stack. Mirror call_closure's save/set/restore. *)
-  let prev_active = !_active_vm in
-  _active_vm := Some vm;
-  let restore () = _active_vm := prev_active in
-  (try
+let resume_vm vm result =
   (match vm.pending_cek with
    | Some cek_state ->
      vm.pending_cek <- None;
@@ -1041,9 +993,7 @@ and resume_vm vm result =
   let pending = List.rev vm.reuse_stack in
   vm.reuse_stack <- [];
   restore_reuse pending;
-  let r = pop vm in
-  restore (); r
-  with e -> restore (); raise e)
+  pop vm
 
 (** Execute a compiled module (top-level bytecode). *)
 let execute_module code globals =
@@ -1122,7 +1072,7 @@ let _jit_is_broken_name n =
     Operand-size logic mirrors [opcode_operand_size] (which is defined
     later, in the disassembly section); inlined here so this helper can
     sit before [jit_compile_lambda] in the file. *)
-let bytecode_find_opcode (pred : int -> bool) (bc : int array) (consts : value array) =
+let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
   let core_operand_size = function
     | 1 | 20 | 21 | 64 | 65 | 128 -> 2  (* u16 *)
     | 16 | 17 | 18 | 19 | 48 | 49 | 144 -> 1  (* u8 *)
@@ -1135,7 +1085,7 @@ let bytecode_find_opcode (pred : int -> bool) (bc : int array) (consts : value a
   let found = ref false in
   while not !found && !ip < len do
     let op = bc.(!ip) in
-    if pred op then found := true
+    if op >= 200 then found := true
     else begin
       ip := !ip + 1;
       let extra = match op with
@@ -1162,49 +1112,6 @@ let bytecode_find_opcode (pred : int -> bool) (bc : int array) (consts : value a
   done;
   !found
 
-let bytecode_uses_extension_opcodes bc consts =
-  bytecode_find_opcode (fun op -> op >= 200) bc consts
-
-(** True if [code] — or any closure nested in its constant pool — installs an
-    exception handler (OP_PUSH_HANDLER = 35), i.e. contains a `guard` /
-    `handler-bind` / dream-catch form. The VM's PUSH_HANDLER only intercepts a
-    VM-level RAISE (opcode 37); it does NOT catch the OCaml [Eval_error] that
-    the `error` primitive throws from inside a CALL/CALL_PRIM in a callee
-    frame. So a JIT-compiled guard silently fails to catch thrown errors (they
-    escape across the JIT frame).
-
-    The scan is RECURSIVE: a curried higher-order function (e.g. Dream's
-    `dream-catch-with = (fn (on-error) (fn (next) (fn (req) (guard ...))))`)
-    has no PUSH_HANDLER in its own body — the guard lives in a nested
-    `OP_CLOSURE` whose code sits in the constant pool. JIT-compiling the outer
-    function would mint that inner guard as a VmClosure with the broken VM
-    handler. Descending into nested closure codes catches this, so the whole
-    closure family runs on the CEK (whose guard catches correctly). Covers
-    dream-catch-with, host wrap-errors, and every guard user centrally. *)
-let rec code_uses_handler code =
-  bytecode_find_opcode (fun op -> op = 35) code.vc_bytecode code.vc_constants
-  || Array.exists (fun c ->
-       match c with
-       | Dict d when Hashtbl.mem d "bytecode" || Hashtbl.mem d "vc-bytecode" ->
-         (try code_uses_handler (code_from_value c) with _ -> false)
-       | _ -> false) code.vc_constants
-
-(** True if [code] — or any nested closure code — references (in its constant
-    pool, as a GLOBAL_GET/CALL name) a function registered in
-    [Sx_types.jit_excluded_caller_names] (a call/cc-establishing form like
-    Common-Lisp's cl-restart-case/cl-handler-case). Such a caller must run on
-    the CEK so the continuation captured inside the called form can escape.
-    The constant-pool string IS the referenced symbol name, so membership is a
-    direct lookup; recurse into nested closure codes. Skipped entirely (no
-    Hashtbl walk) when no escaping forms are registered. *)
-let rec code_refs_escaping_caller code =
-  Array.exists (fun c ->
-    match c with
-    | String s -> Hashtbl.mem Sx_types.jit_excluded_caller_names s
-    | Dict d when Hashtbl.mem d "bytecode" || Hashtbl.mem d "vc-bytecode" ->
-      (try code_refs_escaping_caller (code_from_value c) with _ -> false)
-    | _ -> false) code.vc_constants
-
 let jit_compile_lambda (l : lambda) globals =
   let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
   if !_jit_compiling then (
@@ -1220,13 +1127,6 @@ let jit_compile_lambda (l : lambda) globals =
     None
   ) else if _jit_is_broken_name fn_name then (
     None
-  ) else if Sx_types.jit_name_excluded fn_name then (
-    (* Guest-declared interpret-only function (continuation-using dispatch
-       core, or a whole namespace via prefix). Run on the CEK; the stack VM
-       can't escape through a CEK continuation and may miscompile deep AST
-       recursion into a non-terminating loop. See Sx_types.jit_excluded /
-       jit_excluded_prefixes. *)
-    None
   ) else
   try
     _jit_compiling := true;
@@ -1283,20 +1183,6 @@ let jit_compile_lambda (l : lambda) globals =
             Printf.eprintf "[jit] SKIP %s: bytecode uses extension opcodes (interpret-only in v1)\n%!"
               fn_name;
             None
-          end else if code_uses_handler code then begin
-            (* guard / handler-bind (possibly in a nested closure): VM
-               PUSH_HANDLER doesn't catch the `error` primitive's OCaml
-               exception across frames — run on the CEK. *)
-            Printf.eprintf "[jit] SKIP %s: installs an exception handler (guard) — interpret-only\n%!"
-              fn_name;
-            None
-          end else if Hashtbl.length Sx_types.jit_excluded_caller_names > 0
-                      && code_refs_escaping_caller code then begin
-            (* Calls a call/cc-establishing form (e.g. cl-restart-case): must
-               run on the CEK so the captured continuation can escape. *)
-            Printf.eprintf "[jit] SKIP %s: calls a call/cc-establishing form — interpret-only\n%!"
-              fn_name;
-            None
           end else
             Some { vm_code = code; vm_upvalues = [||];
                    vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }

hosts/ocaml/test/persist_durable_test.sh

@@ -1,144 +0,0 @@
-#!/usr/bin/env bash
-# hosts/ocaml/test/persist_durable_test.sh
-# Acceptance test for the host durable-storage adapter (Sx_persist_store).
-#
-# Exercises `persist/durable-backend` (REAL `perform`, not the mock) under the
-# WORKTREE-built sx_server.exe, and asserts:
-#   1. durable: writes land on disk and read back (the silent-data-loss repro
-#      from plans/persist-on-sx.md now returns correct values).
-#   2. last-seq is monotonic across truncate (compaction never reassigns a seq).
-#   3. kv ops round-trip and delete.
-#   4. recovery: a REAL process restart (write, exit, fresh process, replay)
-#      recovers state from disk.
-#
-# Run from repo root or anywhere; locates the worktree binary relative to itself.
-set -uo pipefail
-
-HERE="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
-ROOT="$(cd "$HERE/../../.." && pwd)"        # repo/worktree root
-cd "$ROOT"
-
-SX="hosts/ocaml/_build/default/bin/sx_server.exe"
-if [ ! -x "$SX" ]; then
-  echo "ERROR: worktree binary not found at $SX — build it first:" >&2
-  echo "  (cd hosts/ocaml && dune build bin/sx_server.exe)" >&2
-  exit 1
-fi
-
-DATADIR="$(mktemp -d)"
-trap 'rm -rf "$DATADIR"' EXIT
-
-PASS=0
-FAIL=0
-check() { # check <label> <got> <expected>
-  if [ "$2" = "$3" ]; then
-    PASS=$((PASS + 1)); printf '  ok   %-40s => %s\n' "$1" "$2"
-  else
-    FAIL=$((FAIL + 1)); printf '  FAIL %-40s got [%s] want [%s]\n' "$1" "$2" "$3"
-  fi
-}
-
-PRELUDE='(epoch 1)
-(load "spec/stdlib.sx")
-(load "lib/r7rs.sx")
-(load "lib/persist/event.sx")
-(load "lib/persist/backend.sx")
-(load "lib/persist/log.sx")
-(load "lib/persist/kv.sx")
-(load "lib/persist/durable.sx")
-(load "lib/persist/blob.sx")
-(epoch 2)'
-
-# run_eval <sx-expr-string>: prints the final (ok-len 2 ...) payload line.
-run_eval() {
-  local expr="$1"
-  printf '%s\n(eval %s)\n' "$PRELUDE" "$expr" \
-    | SX_PERSIST_DIR="$DATADIR" timeout 60 "$SX" 2>/dev/null \
-    | awk '/^\(ok-len 2 / {getline; print; exit}'
-}
-
-# escape an SX program into a single-line double-quoted SX string literal for
-# (eval "..."). The REPL reads one command per physical line, so newlines in the
-# program are collapsed to spaces.
-q() { printf '"%s"' "$(printf '%s' "$1" | tr '\n' ' ' | sed 's/\\/\\\\/g; s/"/\\"/g')"; }
-
-echo "== durable: append/read/last-seq round-trip on disk =="
-GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
-  (begin
-    (persist/append b "s" "x" 0 {:v 1})
-    (persist/append b "s" "x" 0 {:v 2})
-    (list (persist/event-seq (persist/append b "s" "x" 0 {:v 3}))
-          (persist/count b "s")
-          (len (persist/read b "s")))))')")
-check "append/count/read" "$GOT" "(3 3 3)"
-
-echo "== last-seq monotonic across truncate =="
-GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
-  (begin
-    (persist/append b "t" "x" 0 {})
-    (persist/append b "t" "x" 0 {})
-    (persist/append b "t" "x" 0 {})
-    (persist/truncate b "t" 2)
-    (list (persist/last-seq b "t") (persist/count b "t"))))')")
-check "last-seq survives truncate" "$GOT" "(3 1)"
-
-echo "== streams set survives compaction =="
-GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
-  (sort ((get b "streams"))))')")
-check "streams" "$GOT" '("s" "t")'
-
-echo "== kv round-trip + delete =="
-GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
-  (begin
-    (persist/kv-put b "k" {:a 1 :b "two"})
-    (persist/kv-put b "gone" 9)
-    (persist/kv-delete b "gone")
-    (list (get (persist/kv-get b "k") :b)
-          (persist/kv-has? b "k")
-          (persist/kv-has? b "gone"))))')")
-check "kv get/has/delete" "$GOT" '("two" true false)'
-
-echo "== recovery: state survives a REAL process restart =="
-# write in process A then let it exit; the next run is a brand-new process.
-run_eval "$(q '(let ((b (persist/durable-backend)))
-  (begin
-    (persist/append b "r" "ev" 0 {:n 1})
-    (persist/append b "r" "ev" 0 {:n 2})
-    (persist/kv-put b "survive" "yes")
-    (persist/count b "r")))')" >/dev/null
-# fresh process, same SX_PERSIST_DIR — must replay from disk.
-GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
-  (list (persist/count b "r")
-        (persist/last-seq b "r")
-        (get (get (nth (persist/read b "r") 1) :data) :n)
-        (persist/kv-get b "survive")))')")
-check "recovered after restart" "$GOT" '(2 2 2 "yes")'
-
-echo "== blob: content-addressed put/get/has? round-trip =="
-GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
-  (let ((r (persist/blob-store bs "hello world" "text/plain")))
-    (list (persist/blob-size r)
-          (persist/blob-mime r)
-          (persist/blob-fetch bs r)
-          (persist/blob-exists? bs r))))')")
-check "blob size/mime/fetch/exists" "$GOT" '(11 "text/plain" "hello world" true)'
-
-echo "== blob: put is content-addressed (idempotent cid) =="
-GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
-  (equal? (persist/blob-cid (persist/blob-store bs "same bytes" "x"))
-          (persist/blob-cid (persist/blob-store bs "same bytes" "x"))))')")
-check "same bytes -> same cid" "$GOT" "true"
-
-echo "== blob: bytes + ref-in-kv survive a REAL restart =="
-# process A: store a blob, keep only its ref in the durable kv.
-run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
-  (begin (persist/kv-put b "logo" (persist/blob-store bs "PNGDATA" "image/png")) nil))')" >/dev/null
-# fresh process: read the ref from kv, fetch the bytes from the blob store.
-GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
-  (let ((r (persist/kv-get b "logo")))
-    (list (persist/blob-fetch bs r) (persist/blob-exists? bs r) (persist/blob-mime r))))')")
-check "blob recovered via ref after restart" "$GOT" '("PNGDATA" true "image/png")'
-
-echo
-echo "durable adapter: $PASS passed, $FAIL failed"
-[ "$FAIL" -eq 0 ]

lib/acl/api.sx

@@ -1,45 +0,0 @@
-;; lib/acl/api.sx — public ACL surface over an implicit current db.
-;;
-;; Callers load a fact set once, then issue decisions without threading the db
-;; through every call. The current db is module state; (acl/load! facts) rebuilds
-;; it. This is the boundary the rest of rose-ash imports.
-
-(define acl-current-db nil)
-
-;; Replace the current fact base. Rebuilds the Datalog db under the active
-;; ruleset (see lib/acl/engine.sx).
-(define
-  acl/load!
-  (fn
-    (facts)
-    (do (set! acl-current-db (acl-build-db facts)) acl-current-db)))
-
-;; Ensure a db exists, building an empty one on first use.
-(define
-  acl-ensure-db!
-  (fn
-    ()
-    (do
-      (when
-        (= acl-current-db nil)
-        (set! acl-current-db (acl-build-db (list))))
-      acl-current-db)))
-
-;; Public decision against the current db (pure, no logging).
-(define
-  acl/permit?
-  (fn (subj act res) (acl-permit? (acl-ensure-db!) subj act res)))
-
-;; Decision-with-proof against the current db. See lib/acl/explain.sx.
-(define
-  acl/explain
-  (fn (subj act res) (acl-explain (acl-ensure-db!) subj act res)))
-
-;; Audited decision: logs the outcome to the append-only audit log and returns
-;; the boolean. See lib/acl/audit.sx.
-(define
-  acl/audit
-  (fn (subj act res) (acl-audit-decide! (acl-ensure-db!) subj act res)))
-
-;; Recent audited decisions (chronological).
-(define acl/audit-tail (fn (n) (acl-audit-tail n)))

lib/acl/audit.sx

@@ -1,110 +0,0 @@
-;; lib/acl/audit.sx — append-only decision log.
-;;
-;; Every decision routed through acl-audit-decide! is appended to an in-memory
-;; log with a monotonic sequence number (no wall-clock — deterministic and
-;; testable; a host can stamp time at the serializer boundary). The log is
-;; append-only: there is no mutate or delete, only append, tail, clear,
-;; snapshot/restore, and serialize-for-disk.
-
-(define acl-audit-log (list))
-(define acl-audit-seq 0)
-
-;; Copy a list into a fresh, append!-able list. `map`/`rest`-derived lists are
-;; NOT extensible by append! in this runtime (it silently no-ops), so the live
-;; log must always be a list built with `list` + `append!`.
-(define
-  acl-audit-copy
-  (fn
-    (xs)
-    (let
-      ((fresh (list)))
-      (do (for-each (fn (e) (append! fresh e)) xs) fresh))))
-
-(define
-  acl-audit-clear!
-  (fn
-    ()
-    (do (set! acl-audit-log (list)) (set! acl-audit-seq 0) nil)))
-
-;; Append a decision record. Returns the record.
-(define
-  acl-audit-record!
-  (fn
-    (subj act res allowed?)
-    (let
-      ((entry {:allowed? allowed? :act act :subj subj :res res :seq acl-audit-seq}))
-      (do
-        (set! acl-audit-seq (+ acl-audit-seq 1))
-        (append! acl-audit-log entry)
-        entry))))
-
-;; Decide against db, log the outcome, and return the boolean. This is the
-;; audited path; acl-permit? remains the pure, side-effect-free decision.
-(define
-  acl-audit-decide!
-  (fn
-    (db subj act res)
-    (let
-      ((allowed? (acl-permit? db subj act res)))
-      (do (acl-audit-record! subj act res allowed?) allowed?))))
-
-(define acl-audit-count (fn () (len acl-audit-log)))
-
-;; Most recent n entries (in chronological order). n >= log size returns all.
-(define
-  acl-audit-tail
-  (fn
-    (n)
-    (let
-      ((total (len acl-audit-log)))
-      (if
-        (<= total n)
-        acl-audit-log
-        (acl-audit-drop acl-audit-log (- total n))))))
-
-(define
-  acl-audit-drop
-  (fn
-    (xs k)
-    (if (<= k 0) xs (acl-audit-drop (rest xs) (- k 1)))))
-
-;; Structured snapshot for save/restore — a {:seq :entries} value carrying a
-;; copy of the log (so later appends don't mutate a held snapshot).
-(define acl-audit-snapshot (fn () {:seq acl-audit-seq :entries (acl-audit-copy acl-audit-log)}))
-
-;; Replace the live log from a snapshot. Restores both entries and the seq
-;; counter so subsequent records continue numbering correctly. The log is
-;; rebuilt as a fresh append!-able list (see acl-audit-copy).
-(define
-  acl-audit-restore!
-  (fn
-    (snap)
-    (do
-      (set! acl-audit-log (acl-audit-copy (get snap :entries)))
-      (set! acl-audit-seq (get snap :seq))
-      nil)))
-
-;; Serialize the whole log to a disk-ready string: one record per line,
-;; "seq\tsubj\tact\tres\tallowed?". A host writes this; structured reload is via
-;; snapshot/restore.
-(define
-  acl-audit-serialize
-  (fn
-    ()
-    (reduce
-      (fn
-        (acc e)
-        (str
-          acc
-          (get e :seq)
-          "\t"
-          (get e :subj)
-          "\t"
-          (get e :act)
-          "\t"
-          (get e :res)
-          "\t"
-          (get e :allowed?)
-          "\n"))
-      ""
-      acl-audit-log)))

lib/acl/conformance.conf

@@ -1,32 +0,0 @@
-# ACL conformance config — sourced by lib/guest/conformance.sh.
-
-LANG_NAME=acl
-MODE=dict
-
-PRELOADS=(
-  lib/datalog/tokenizer.sx
-  lib/datalog/parser.sx
-  lib/datalog/unify.sx
-  lib/datalog/db.sx
-  lib/datalog/builtins.sx
-  lib/datalog/aggregates.sx
-  lib/datalog/strata.sx
-  lib/datalog/eval.sx
-  lib/datalog/api.sx
-  lib/datalog/magic.sx
-  lib/acl/schema.sx
-  lib/acl/facts.sx
-  lib/acl/engine.sx
-  lib/acl/explain.sx
-  lib/acl/audit.sx
-  lib/acl/federation.sx
-  lib/acl/api.sx
-)
-
-SUITES=(
-  "direct:lib/acl/tests/direct.sx:(acl-direct-tests-run!)"
-  "inherit:lib/acl/tests/inherit.sx:(acl-inherit-tests-run!)"
-  "explain:lib/acl/tests/explain.sx:(acl-explain-tests-run!)"
-  "fed:lib/acl/tests/fed.sx:(acl-fed-tests-run!)"
-  "harden:lib/acl/tests/harden.sx:(acl-harden-tests-run!)"
-)

lib/acl/conformance.sh

@@ -1,3 +0,0 @@
-#!/usr/bin/env bash
-# Thin wrapper — see lib/guest/conformance.sh and lib/acl/conformance.conf.
-exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

lib/acl/engine.sx

@@ -1,72 +0,0 @@
-;; lib/acl/engine.sx — ACL ruleset + decision reducer over lib/datalog/.
-;;
-;; The engine is a thin layer: it owns the permit ruleset (SX data rules) and
-;; reduces a (subject, action, resource) decision to a Datalog query against a
-;; db built from EDB facts. The rule engine itself is Datalog's.
-;;
-;; Policy — inheritance + federation with deny-overrides:
-;;
-;;   eff_grant(S,A,R) :- grant(S,A,R).                         ; direct
-;;   eff_grant(S,A,R) :- member_of(S,G), eff_grant(G,A,R).     ; group/role chain
-;;   eff_grant(S,A,R) :- child_of(R,P), eff_grant(S,A,P).      ; resource tree
-;;   eff_grant(S,A,R) :- member_of(S,Role), role_grant(Role,A,R). ; role expansion
-;;   eff_grant(S,A,R) :- delegate(Peer,S,A,R),                 ; federated grant
-;;                       trust(Peer,L), level_covers(L,A).
-;;
-;;   eff_deny(S,A,R)  :- deny(S,A,R).                          ; direct
-;;   eff_deny(S,A,R)  :- member_of(S,G), eff_deny(G,A,R).      ; group chain
-;;   eff_deny(S,A,R)  :- child_of(R,P), eff_deny(S,A,P).       ; resource tree
-;;
-;;   permit(S,A,R)    :- eff_grant(S,A,R), not eff_deny(S,A,R).
-;;
-;; DENY-OVERRIDES: an effective deny anywhere in the inheritance closure of
-;; (S,A,R) defeats any effective grant — including federated grants. Deny
-;; inherits through the *same* group and resource chains as grant, so a
-;; group-level or ancestor-resource deny is authoritative for members/
-;; descendants. This is the principled, fail-safe reading of "deny wins".
-;;
-;; FEDERATION — non-transitive trust: a peer's `delegate` fact only grants if a
-;; *local* `trust(Peer, L)` exists AND that level `level_covers` the action.
-;; Trust is re-checked on every query (it is a body literal), never baked in at
-;; fact-ingestion time, so revoking trust or narrowing a level takes effect
-;; immediately on the next decision.
-;;
-;; Termination & stratification:
-;;   - eff_grant/eff_deny recurse only over member_of and child_of, which are
-;;     EDB relations with no function symbols, so the closure is finite (cyclic
-;;     membership/containment just reaches a fixpoint, never loops). The
-;;     federation rule is non-recursive.
-;;   - permit negates eff_deny; neither eff_grant nor eff_deny depends on
-;;     permit, so the program is stratifiable (permit sits in a higher stratum).
-
-(define
-  acl-rules
-  (quote
-    ((eff_grant S A R <- (grant S A R))
-      (eff_grant S A R <- (member_of S G) (eff_grant G A R))
-      (eff_grant S A R <- (child_of R P) (eff_grant S A P))
-      (eff_grant S A R <- (member_of S Role) (role_grant Role A R))
-      (eff_grant
-        S
-        A
-        R
-        <-
-        (delegate Peer S A R)
-        (trust Peer L)
-        (level_covers L A))
-      (eff_deny S A R <- (deny S A R))
-      (eff_deny S A R <- (member_of S G) (eff_deny G A R))
-      (eff_deny S A R <- (child_of R P) (eff_deny S A P))
-      (permit S A R <- (eff_grant S A R) {:neg (eff_deny S A R)}))))
-
-;; Build a Datalog db from a list of EDB facts under the ACL ruleset.
-(define acl-build-db (fn (facts) (dl-program-data facts acl-rules)))
-
-;; Core decision: does the db permit subject S to perform action A on
-;; resource R? Reduces to a ground Datalog query on the derived `permit`
-;; relation — non-empty result means permitted.
-(define
-  acl-permit?
-  (fn
-    (db subj act res)
-    (> (len (dl-query db (list (quote permit) subj act res))) 0)))

lib/acl/explain.sx

@@ -1,125 +0,0 @@
-;; lib/acl/explain.sx — proof-tree reconstruction over the saturated db.
-;;
-;; lib/datalog/ records derived facts but not their provenance, so the proof is
-;; reconstructed here by goal-directed search over the *saturated* db: for a
-;; ground goal we find the first ACL rule (in rule order) whose body holds, take
-;; the first solution binding its remaining variables, and recurse on each body
-;; literal. Negated literals are recorded as verified `:neg-ok` leaves.
-;;
-;; CANONICAL DERIVATION: the Datalog derivation graph is a DAG (a fact may hold
-;; many ways). We pick ONE canonical proof — first matching rule, first solution
-;; — matching the rule order in lib/acl/engine.sx (direct/EDB rules first). A
-;; depth cap guards against pathological cyclic data producing unbounded search.
-;;
-;; A proof node is one of:
-;;   {:fact <lit> :via "edb"}                       — base EDB fact
-;;   {:fact <lit> :rule <head> :body (<node|negleaf> ...)}  — derived
-;;   {:neg-ok <lit>}                                — negation verified to fail
-;;   {:fact <lit> :truncated true}                  — depth cap hit
-
-(define acl-proof-max-depth 64)
-
-;; Substitute a body literal, descending into {:neg ...} dicts (dl-apply-subst
-;; does not recurse into dicts, which would leak the neg's free vars).
-(define
-  acl-subst-lit
-  (fn
-    (lit s)
-    (if
-      (and (dict? lit) (has-key? lit :neg))
-      {:neg (dl-apply-subst (get lit :neg) s)}
-      (dl-apply-subst lit s))))
-
-(define
-  acl-lit-edb?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (symbol? (first lit))
-      (has-key? acl-edb-arity (symbol->string (first lit))))))
-
-(define
-  acl-subst-zip!
-  (fn
-    (d ks vs)
-    (when
-      (> (len ks) 0)
-      (do
-        (dict-set! d (symbol->string (first ks)) (first vs))
-        (acl-subst-zip! d (rest ks) (rest vs))))))
-
-;; Bind a rule head's variables to a ground goal's arguments (positional).
-(define
-  acl-bind-head
-  (fn
-    (head goal)
-    (let
-      ((d {}))
-      (do (acl-subst-zip! d (rest head) (rest goal)) d))))
-
-(define
-  acl-subst-union
-  (fn
-    (a b)
-    (let
-      ((d {}))
-      (do
-        (for-each (fn (k) (dict-set! d k (get a k))) (keys a))
-        (for-each (fn (k) (dict-set! d k (get b k))) (keys b))
-        d))))
-
-(define acl-prove (fn (db goal) (acl-prove-d db goal 0)))
-
-(define
-  acl-prove-d
-  (fn
-    (db goal depth)
-    (cond
-      ((> depth acl-proof-max-depth) {:truncated true :fact goal})
-      ((acl-lit-edb? goal)
-        (if (> (len (dl-query db goal)) 0) {:via "edb" :fact goal} nil))
-      (else (acl-prove-rules db goal acl-rules depth)))))
-
-(define
-  acl-prove-rules
-  (fn
-    (db goal rules depth)
-    (if
-      (= (len rules) 0)
-      nil
-      (let
-        ((p (dl-rule-from-list (first rules))))
-        (if
-          (= (first (get p :head)) (first goal))
-          (let
-            ((hs (acl-bind-head (get p :head) goal)))
-            (let
-              ((qbody (map (fn (l) (acl-subst-lit l hs)) (get p :body))))
-              (let
-                ((sols (dl-query db qbody)))
-                (if
-                  (> (len sols) 0)
-                  (acl-prove-build db goal p hs (first sols) depth)
-                  (acl-prove-rules db goal (rest rules) depth)))))
-          (acl-prove-rules db goal (rest rules) depth))))))
-
-(define
-  acl-prove-build
-  (fn
-    (db goal p hs sol depth)
-    (let ((full (acl-subst-union hs sol))) {:body (map (fn (l) (let ((g (acl-subst-lit l full))) (if (and (dict? g) (has-key? g :neg)) {:neg-ok (get g :neg)} (acl-prove-d db g (+ depth 1))))) (get p :body)) :rule (get p :head) :fact goal})))
-
-;; Public decision-with-proof. Returns:
-;;   {:allowed? <bool> :proof <node|nil> :reason <eff_deny proof|nil>}
-;; When permitted, :proof is the permit derivation. When denied, :proof is nil
-;; and :reason carries the blocking eff_deny proof if one exists (an explicit or
-;; inherited deny), else nil (simply no grant).
-(define
-  acl-explain
-  (fn
-    (db subj act res)
-    (let
-      ((proof (acl-prove db (list (quote permit) subj act res))))
-      (if (= proof nil) {:allowed? false :proof nil :reason (acl-prove db (list (quote eff_deny) subj act res))} {:allowed? true :proof proof :reason nil}))))

lib/acl/facts.sx

@@ -1,47 +0,0 @@
-;; lib/acl/facts.sx — EDB fact constructors.
-;;
-;; Each constructor returns a Datalog fact tuple (a list whose head is the
-;; predicate symbol). These are the only shapes lib/acl/engine.sx feeds to
-;; lib/datalog/.
-;;   Phase 1: actor/resource/grant/deny.
-;;   Phase 2: member_of (subject -> group/role), child_of (resource -> parent),
-;;            role_grant (role -> action,resource capability).
-;;   Phase 4: peer/trust/delegate/level_covers (federation).
-
-(define acl-actor (fn (id kind) (list (quote actor) id kind)))
-
-(define acl-resource-fact (fn (id kind) (list (quote resource) id kind)))
-
-(define acl-grant (fn (subj act res) (list (quote grant) subj act res)))
-
-(define acl-deny (fn (subj act res) (list (quote deny) subj act res)))
-
-;; subject S is a member of group/role G (one hop; transitivity is derived).
-(define acl-member-of (fn (subj grp) (list (quote member_of) subj grp)))
-
-;; resource R is a child of parent P (one hop; transitivity is derived).
-(define acl-child-of (fn (res parent) (list (quote child_of) res parent)))
-
-;; role confers capability (act on res) to every member of the role.
-(define
-  acl-role-grant
-  (fn (role act res) (list (quote role_grant) role act res)))
-
-;; --- federation ---
-
-;; a known peer instance at addr, of some kind (e.g. peer).
-(define acl-peer (fn (addr kind) (list (quote peer) addr kind)))
-
-;; local trust in a peer at a named level. Gates delegated grants at query time.
-(define acl-trust (fn (peer level) (list (quote trust) peer level)))
-
-;; a peer asserts that subject S may A on R. Only takes effect if local trust in
-;; that peer covers action A (see level_covers).
-(define
-  acl-delegate
-  (fn (peer subj act res) (list (quote delegate) peer subj act res)))
-
-;; local policy: trust `level` authorises delegated grants for action `act`.
-(define
-  acl-level-covers
-  (fn (level act) (list (quote level_covers) level act)))

lib/acl/federation.sx

@@ -1,61 +0,0 @@
-;; lib/acl/federation.sx — cross-instance ACL facts + revocation.
-;;
-;; fed-sx replicates ACL facts between instances; this module models the local
-;; side. A peer's authority arrives as `delegate(Peer, S, A, R)` facts, which
-;; only take effect when a local `trust(Peer, L)` and `level_covers(L, A)`
-;; authorise them (enforced by the engine rule, re-checked every query). The
-;; actual network transport is fed-sx's job and is mocked in tests as a dict.
-;;
-;; Trust is NOT transitive: trusting peer α does not extend to peers α trusts.
-;; Only delegate facts that α itself asserts, and that local trust covers, flow.
-
-;; Mock fed-sx pull: `transport` is a dict mapping a peer address (its string
-;; name) to the list of delegate facts that peer asserts. Returns the facts for
-;; `addr`, or an empty list if the peer is unknown / unreachable.
-(define
-  acl-fed-fetch
-  (fn
-    (transport addr)
-    (let
-      ((k (if (symbol? addr) (symbol->string addr) addr)))
-      (if (has-key? transport k) (get transport k) (list)))))
-
-;; Gather delegate facts from every peer in `addrs` via the transport.
-(define
-  acl-fed-collect
-  (fn
-    (transport addrs)
-    (let
-      ((acc (list)))
-      (do
-        (for-each
-          (fn
-            (addr)
-            (for-each
-              (fn (f) (append! acc f))
-              (acl-fed-fetch transport addr)))
-          addrs)
-        acc))))
-
-;; Build a db from local facts plus delegate facts pulled from `peers`. Local
-;; facts must include the `trust`/`level_covers` policy; replicated delegate
-;; facts are gated against it by the engine rule at query time.
-(define
-  acl-fed-build-db
-  (fn
-    (local-facts transport peers)
-    (let
-      ((all (list)))
-      (do
-        (for-each (fn (f) (append! all f)) local-facts)
-        (for-each
-          (fn (f) (append! all f))
-          (acl-fed-collect transport peers))
-        (acl-build-db all)))))
-
-;; Propagated revocation: retract a replicated fact (e.g. a peer's delegate, or
-;; local trust) from a live db. The next decision re-saturates and reflects it.
-(define acl-revoke! (fn (db fact) (do (dl-retract! db fact) db)))
-
-;; Propagated assertion: ingest a newly replicated fact into a live db.
-(define acl-fed-assert! (fn (db fact) (do (dl-assert! db fact) db)))

lib/acl/schema.sx

@@ -1,71 +0,0 @@
-;; lib/acl/schema.sx — ACL sorts and EDB predicate vocabulary.
-;;
-;; Datalog is untyped; this module is the schema-as-data layer. It declares
-;; the subject/resource/action sorts and the arity of every EDB predicate the
-;; ACL engine recognises, plus light validators. Facts that pass these checks
-;; are well-formed inputs to lib/acl/engine.sx.
-
-(define acl-subject-kinds (quote (user group role service)))
-(define acl-resource-kinds (quote (page post thread peer)))
-
-;; Actions are open-ended (a grant may name any action symbol), but these are
-;; the platform's well-known verbs.
-(define acl-actions (quote (read edit comment moderate federate)))
-
-;; EDB predicate name -> arity.
-;;   Phase 1: actor/resource/grant/deny.
-;;   Phase 2: member_of (subject->group/role), child_of (resource->parent),
-;;            role_grant (role->action,resource).
-;;   Phase 4: peer (addr->kind), trust (peer->level),
-;;            delegate (peer->subj,action,resource), level_covers (level->action).
-(define acl-edb-arity {:role_grant 3 :child_of 2 :trust 2 :peer 2 :actor 2 :level_covers 2 :delegate 4 :member_of 2 :deny 3 :grant 3 :resource 2})
-
-(define
-  acl-member?
-  (fn
-    (x xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= (first xs) x) true)
-      (else (acl-member? x (rest xs))))))
-
-(define acl-subject-kind? (fn (k) (acl-member? k acl-subject-kinds)))
-
-(define acl-resource-kind? (fn (k) (acl-member? k acl-resource-kinds)))
-
-(define acl-known-action? (fn (a) (acl-member? a acl-actions)))
-
-;; A fact is a list whose head is a predicate symbol. Valid when the predicate
-;; is known and the argument count matches the declared arity.
-(define
-  acl-fact-valid?
-  (fn
-    (f)
-    (and
-      (list? f)
-      (> (len f) 0)
-      (symbol? (first f))
-      (let
-        ((pred (symbol->string (first f))))
-        (and
-          (has-key? acl-edb-arity pred)
-          (= (- (len f) 1) (get acl-edb-arity pred)))))))
-
-;; Return the sublist of facts that fail acl-fact-valid?. Empty list means the
-;; whole set is well-formed. acl-build-db stays lenient (Datalog accepts any
-;; tuple, and custom action symbols are allowed); callers opt in to checking.
-(define
-  acl-validate-facts
-  (fn
-    (facts)
-    (let
-      ((bad (list)))
-      (do
-        (for-each
-          (fn (f) (when (not (acl-fact-valid? f)) (append! bad f)))
-          facts)
-        bad))))
-
-(define
-  acl-facts-valid?
-  (fn (facts) (= (len (acl-validate-facts facts)) 0)))

lib/acl/scoreboard.json

@@ -1,14 +0,0 @@
-{
-  "lang": "acl",
-  "total_passed": 145,
-  "total_failed": 0,
-  "total": 145,
-  "suites": [
-    {"name":"direct","passed":24,"failed":0,"total":24},
-    {"name":"inherit","passed":30,"failed":0,"total":30},
-    {"name":"explain","passed":35,"failed":0,"total":35},
-    {"name":"fed","passed":31,"failed":0,"total":31},
-    {"name":"harden","passed":25,"failed":0,"total":25}
-  ],
-  "generated": "2026-06-06T22:43:27+00:00"
-}

lib/acl/scoreboard.md

@@ -1,11 +0,0 @@
-# acl scoreboard
-
-**145 / 145 passing** (0 failure(s)).
-
-| Suite | Passed | Total | Status |
-|-------|--------|-------|--------|
-| direct | 24 | 24 | ok |
-| inherit | 30 | 30 | ok |
-| explain | 35 | 35 | ok |
-| fed | 31 | 31 | ok |
-| harden | 25 | 25 | ok |

lib/acl/tests/direct.sx

@@ -1,170 +0,0 @@
-;; lib/acl/tests/direct.sx — Phase 1: direct grants + deny-overrides.
-
-(define acl-dt-pass 0)
-(define acl-dt-fail 0)
-(define acl-dt-failures (list))
-
-(define
-  acl-dt-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! acl-dt-pass (+ acl-dt-pass 1))
-      (do
-        (set! acl-dt-fail (+ acl-dt-fail 1))
-        (append!
-          acl-dt-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; A small fixture used by most cases: alice can read page1, is denied edit on
-;; page1, and a service may federate peer1.
-(define
-  acl-dt-fixture
-  (fn
-    ()
-    (acl-build-db
-      (list
-        (acl-actor (quote alice) (quote user))
-        (acl-actor (quote svc1) (quote service))
-        (acl-resource-fact (quote page1) (quote page))
-        (acl-resource-fact (quote peer1) (quote peer))
-        (acl-grant (quote alice) (quote read) (quote page1))
-        (acl-grant (quote alice) (quote edit) (quote page1))
-        (acl-deny (quote alice) (quote edit) (quote page1))
-        (acl-grant (quote svc1) (quote federate) (quote peer1))))))
-
-(define
-  acl-dt-run-all!
-  (fn
-    ()
-    (let
-      ((db (acl-dt-fixture)))
-      (do
-        (acl-dt-check!
-          "direct grant permits"
-          (acl-permit? db (quote alice) (quote read) (quote page1))
-          true)
-        (acl-dt-check!
-          "service grant permits federate"
-          (acl-permit? db (quote svc1) (quote federate) (quote peer1))
-          true)
-        (acl-dt-check!
-          "missing action denied"
-          (acl-permit? db (quote alice) (quote comment) (quote page1))
-          false)
-        (acl-dt-check!
-          "missing resource denied"
-          (acl-permit? db (quote alice) (quote read) (quote page2))
-          false)
-        (acl-dt-check!
-          "missing subject denied"
-          (acl-permit? db (quote bob) (quote read) (quote page1))
-          false)
-        (acl-dt-check!
-          "wrong subject for service grant denied"
-          (acl-permit? db (quote alice) (quote federate) (quote peer1))
-          false)
-        (acl-dt-check!
-          "grant plus deny -> deny wins"
-          (acl-permit? db (quote alice) (quote edit) (quote page1))
-          false)
-        (acl-dt-check!
-          "deny alone still denies"
-          (acl-permit?
-            (acl-build-db
-              (list (acl-deny (quote alice) (quote read) (quote page1))))
-            (quote alice)
-            (quote read)
-            (quote page1))
-          false)
-        (acl-dt-check!
-          "deny on edit does not block read"
-          (acl-permit? db (quote alice) (quote read) (quote page1))
-          true)
-        (acl-dt-check!
-          "empty db denies"
-          (acl-permit?
-            (acl-build-db (list))
-            (quote alice)
-            (quote read)
-            (quote page1))
-          false)
-        (let
-          ((db2 (acl-build-db (list (acl-grant (quote a) (quote read) (quote r)) (acl-grant (quote b) (quote read) (quote r)) (acl-deny (quote b) (quote read) (quote r))))))
-          (do
-            (acl-dt-check!
-              "subject a allowed"
-              (acl-permit? db2 (quote a) (quote read) (quote r))
-              true)
-            (acl-dt-check!
-              "subject b denied by override"
-              (acl-permit? db2 (quote b) (quote read) (quote r))
-              false)))
-        (let
-          ((db3 (acl-build-db (list (acl-actor (quote editors) (quote role)) (acl-grant (quote editors) (quote edit) (quote post1))))))
-          (acl-dt-check!
-            "role subject direct grant"
-            (acl-permit? db3 (quote editors) (quote edit) (quote post1))
-            true))
-        (do
-          (acl/load!
-            (list
-              (acl-grant (quote carol) (quote moderate) (quote thread1))))
-          (acl-dt-check!
-            "api permit via current db"
-            (acl/permit? (quote carol) (quote moderate) (quote thread1))
-            true)
-          (acl-dt-check!
-            "api deny via current db"
-            (acl/permit? (quote carol) (quote read) (quote thread1))
-            false))
-        (do
-          (acl/load! (list))
-          (acl-dt-check!
-            "api reload clears prior grants"
-            (acl/permit? (quote carol) (quote moderate) (quote thread1))
-            false))
-        (acl-dt-check!
-          "schema grant arity valid"
-          (acl-fact-valid? (acl-grant (quote x) (quote read) (quote y)))
-          true)
-        (acl-dt-check!
-          "schema bad arity invalid"
-          (acl-fact-valid? (list (quote grant) (quote x)))
-          false)
-        (acl-dt-check!
-          "schema unknown predicate invalid"
-          (acl-fact-valid? (list (quote frobnicate) (quote x)))
-          false)
-        (acl-dt-check!
-          "schema subject kind known"
-          (acl-subject-kind? (quote service))
-          true)
-        (acl-dt-check!
-          "schema resource kind unknown"
-          (acl-resource-kind? (quote galaxy))
-          false)
-        (acl-dt-check!
-          "schema known action"
-          (acl-known-action? (quote moderate))
-          true)
-        (acl-dt-check!
-          "grant constructor shape"
-          (acl-grant (quote u) (quote read) (quote p))
-          (list (quote grant) (quote u) (quote read) (quote p)))
-        (acl-dt-check!
-          "actor constructor shape"
-          (acl-actor (quote u) (quote user))
-          (list (quote actor) (quote u) (quote user)))))))
-
-(define
-  acl-direct-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-dt-pass 0)
-      (set! acl-dt-fail 0)
-      (set! acl-dt-failures (list))
-      (acl-dt-run-all!)
-      {:failures acl-dt-failures :total (+ acl-dt-pass acl-dt-fail) :passed acl-dt-pass :failed acl-dt-fail})))

lib/acl/tests/explain.sx

@@ -1,316 +0,0 @@
-;; lib/acl/tests/explain.sx — Phase 3: proof correctness + audit completeness.
-
-(define acl-et-pass 0)
-(define acl-et-fail 0)
-(define acl-et-failures (list))
-
-;; Name-based deep equality. The host `=` compares symbols by interned
-;; identity, which is unstable across substitution/saturation; comparing by
-;; name (as the datalog suite does) makes structural assertions deterministic.
-(define
-  acl-et-eq?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (acl-et-eq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (acl-et-eq-d? a b ka 0))))
-      ((and (symbol? a) (symbol? b))
-        (= (symbol->string a) (symbol->string b)))
-      (else (= a b)))))
-
-(define
-  acl-et-eq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (acl-et-eq? (nth a i) (nth b i))) false)
-      (else (acl-et-eq-l? a b (+ i 1))))))
-
-(define
-  acl-et-eq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (acl-et-eq? (get a k) (get b k))))
-        false)
-      (else (acl-et-eq-d? a b ka (+ i 1))))))
-
-(define
-  acl-et-check!
-  (fn
-    (name got expected)
-    (if
-      (acl-et-eq? got expected)
-      (set! acl-et-pass (+ acl-et-pass 1))
-      (do
-        (set! acl-et-fail (+ acl-et-fail 1))
-        (append!
-          acl-et-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; --- proof-tree walkers ---
-
-;; True if EDB fact `target` appears as a base leaf anywhere in the proof.
-(define
-  acl-et-has-leaf?
-  (fn
-    (node target)
-    (cond
-      ((= node nil) false)
-      ((and (dict? node) (has-key? node :via))
-        (acl-et-eq? (get node :fact) target))
-      ((and (dict? node) (has-key? node :body))
-        (acl-et-any-leaf? (get node :body) target))
-      (else false))))
-
-(define
-  acl-et-any-leaf?
-  (fn
-    (nodes target)
-    (cond
-      ((= (len nodes) 0) false)
-      ((acl-et-has-leaf? (first nodes) target) true)
-      (else (acl-et-any-leaf? (rest nodes) target)))))
-
-;; True if the proof records a verified negation (deny did not fire).
-(define
-  acl-et-has-negok?
-  (fn
-    (node)
-    (cond
-      ((= node nil) false)
-      ((and (dict? node) (has-key? node :neg-ok)) true)
-      ((and (dict? node) (has-key? node :body))
-        (acl-et-any-negok? (get node :body)))
-      (else false))))
-
-(define
-  acl-et-any-negok?
-  (fn
-    (nodes)
-    (cond
-      ((= (len nodes) 0) false)
-      ((acl-et-has-negok? (first nodes)) true)
-      (else (acl-et-any-negok? (rest nodes))))))
-
-(define
-  acl-et-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p))))))
-        (let
-          ((e (acl-explain db (quote u) (quote read) (quote p))))
-          (do
-            (acl-et-check! "direct: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "direct: proof root fact"
-              (get (get e :proof) :fact)
-              (list (quote permit) (quote u) (quote read) (quote p)))
-            (acl-et-check!
-              "direct: grant leaf present"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote grant) (quote u) (quote read) (quote p)))
-              true)
-            (acl-et-check!
-              "direct: negation verified"
-              (acl-et-has-negok? (get e :proof))
-              true)
-            (acl-et-check!
-              "direct: reason nil when allowed"
-              (get e :reason)
-              nil))))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-grant (quote org) (quote read) (quote doc))))))
-        (let
-          ((e (acl-explain db (quote alice) (quote read) (quote doc))))
-          (do
-            (acl-et-check! "group: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "group: member_of alice leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote member_of) (quote alice) (quote team)))
-              true)
-            (acl-et-check!
-              "group: member_of team leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote member_of) (quote team) (quote org)))
-              true)
-            (acl-et-check!
-              "group: grant org leaf at base"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote grant) (quote org) (quote read) (quote doc)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
-        (let
-          ((e (acl-explain db (quote u) (quote read) (quote sec))))
-          (do
-            (acl-et-check! "resource: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "resource: child_of leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote child_of) (quote sec) (quote book)))
-              true)
-            (acl-et-check!
-              "resource: grant on parent leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote grant) (quote u) (quote read) (quote book)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
-        (let
-          ((e (acl-explain db (quote bob) (quote edit) (quote page1))))
-          (do
-            (acl-et-check! "role: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "role: member_of leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote member_of) (quote bob) (quote editor)))
-              true)
-            (acl-et-check!
-              "role: role_grant leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list
-                  (quote role_grant)
-                  (quote editor)
-                  (quote edit)
-                  (quote page1)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote edit) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
-        (let
-          ((e (acl-explain db (quote u) (quote edit) (quote p))))
-          (do
-            (acl-et-check! "deny: not allowed" (get e :allowed?) false)
-            (acl-et-check! "deny: no proof" (get e :proof) nil)
-            (acl-et-check!
-              "deny: reason root is eff_deny"
-              (get (get e :reason) :fact)
-              (list (quote eff_deny) (quote u) (quote edit) (quote p)))
-            (acl-et-check!
-              "deny: reason has deny leaf"
-              (acl-et-has-leaf?
-                (get e :reason)
-                (list (quote deny) (quote u) (quote edit) (quote p)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
-        (let
-          ((e (acl-explain db (quote alice) (quote read) (quote doc))))
-          (do
-            (acl-et-check!
-              "inherited deny: not allowed"
-              (get e :allowed?)
-              false)
-            (acl-et-check!
-              "inherited deny: reason has member_of leaf"
-              (acl-et-has-leaf?
-                (get e :reason)
-                (list (quote member_of) (quote alice) (quote team)))
-              true)
-            (acl-et-check!
-              "inherited deny: reason has group deny leaf"
-              (acl-et-has-leaf?
-                (get e :reason)
-                (list (quote deny) (quote team) (quote read) (quote doc)))
-              true))))
-      (let
-        ((db (acl-build-db (list))))
-        (let
-          ((e (acl-explain db (quote u) (quote read) (quote p))))
-          (do
-            (acl-et-check! "no grant: not allowed" (get e :allowed?) false)
-            (acl-et-check! "no grant: proof nil" (get e :proof) nil)
-            (acl-et-check! "no grant: reason nil" (get e :reason) nil))))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
-        (do
-          (acl-audit-clear!)
-          (acl-et-check! "audit: starts empty" (acl-audit-count) 0)
-          (acl-et-check!
-            "audit decide allowed returns true"
-            (acl-audit-decide! db (quote u) (quote read) (quote p))
-            true)
-          (acl-et-check!
-            "audit decide denied returns false"
-            (acl-audit-decide! db (quote u) (quote edit) (quote p))
-            false)
-          (acl-audit-decide! db (quote u) (quote comment) (quote p))
-          (acl-et-check!
-            "audit: count after three decisions"
-            (acl-audit-count)
-            3)
-          (acl-et-check!
-            "audit: tail size respects n"
-            (len (acl-audit-tail 2))
-            2)
-          (acl-et-check!
-            "audit: tail returns most recent"
-            (get (first (acl-audit-tail 1)) :act)
-            (quote comment))
-          (acl-et-check!
-            "audit: first record seq is 0"
-            (get (first (acl-audit-tail 3)) :seq)
-            0)
-          (acl-et-check!
-            "audit: allowed flag recorded"
-            (get (first (acl-audit-tail 3)) :allowed?)
-            true)
-          (acl-et-check!
-            "audit: serialize line count"
-            (len (acl-et-lines (acl-audit-serialize)))
-            3)
-          (acl-audit-clear!)
-          (acl-et-check!
-            "audit: clear resets count"
-            (acl-audit-count)
-            0))))))
-
-;; count newline-terminated lines in a serialized log
-(define acl-et-lines (fn (s) (acl-et-count-nl s 0 0)))
-(define
-  acl-et-count-nl
-  (fn
-    (s i n)
-    (if
-      (>= i (len s))
-      (if (= n 0) (list) (acl-et-rangelist n))
-      (acl-et-count-nl
-        s
-        (+ i 1)
-        (if (= (slice s i (+ i 1)) "\n") (+ n 1) n)))))
-(define
-  acl-et-rangelist
-  (fn
-    (n)
-    (if
-      (<= n 0)
-      (list)
-      (cons n (acl-et-rangelist (- n 1))))))
-
-(define
-  acl-explain-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-et-pass 0)
-      (set! acl-et-fail 0)
-      (set! acl-et-failures (list))
-      (acl-et-run-all!)
-      {:failures acl-et-failures :total (+ acl-et-pass acl-et-fail) :passed acl-et-pass :failed acl-et-fail})))

lib/acl/tests/fed.sx

@@ -1,273 +0,0 @@
-;; lib/acl/tests/fed.sx — Phase 4: federation (peer trust, delegation,
-;; cross-instance chains, revocation). fed-sx transport is mocked as a dict.
-
-(define acl-ft-pass 0)
-(define acl-ft-fail 0)
-(define acl-ft-failures (list))
-
-;; Name-based deep equality (host `=` compares symbols by unstable interned
-;; identity; see lib/acl/tests/explain.sx).
-(define
-  acl-ft-eq?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (acl-ft-eq-l? a b 0)))
-      ((and (symbol? a) (symbol? b))
-        (= (symbol->string a) (symbol->string b)))
-      (else (= a b)))))
-(define
-  acl-ft-eq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (acl-ft-eq? (nth a i) (nth b i))) false)
-      (else (acl-ft-eq-l? a b (+ i 1))))))
-
-(define
-  acl-ft-check!
-  (fn
-    (name got expected)
-    (if
-      (acl-ft-eq? got expected)
-      (set! acl-ft-pass (+ acl-ft-pass 1))
-      (do
-        (set! acl-ft-fail (+ acl-ft-fail 1))
-        (append!
-          acl-ft-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; proof leaf walker (federated proofs reconstruct through the engine rule).
-(define
-  acl-ft-has-leaf?
-  (fn
-    (node target)
-    (cond
-      ((= node nil) false)
-      ((and (dict? node) (has-key? node :via))
-        (acl-ft-eq? (get node :fact) target))
-      ((and (dict? node) (has-key? node :body))
-        (acl-ft-any-leaf? (get node :body) target))
-      (else false))))
-(define
-  acl-ft-any-leaf?
-  (fn
-    (nodes target)
-    (cond
-      ((= (len nodes) 0) false)
-      ((acl-ft-has-leaf? (first nodes) target) true)
-      (else (acl-ft-any-leaf? (rest nodes) target)))))
-
-(define acl-ft-p? (fn (db s a r) (acl-permit? db s a r)))
-
-;; A standard federation fixture: local trusts peer alpha at "readonly", which
-;; covers read+comment. alpha delegates several capabilities to alice.
-(define
-  acl-ft-fixture
-  (fn
-    ()
-    (acl-build-db
-      (list
-        (acl-trust (quote alpha) (quote readonly))
-        (acl-level-covers (quote readonly) (quote read))
-        (acl-level-covers (quote readonly) (quote comment))
-        (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))
-        (acl-delegate (quote alpha) (quote alice) (quote edit) (quote doc))))))
-
-(define
-  acl-ft-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((db (acl-ft-fixture)))
-        (do
-          (acl-ft-check!
-            "trusted delegate, level covers action -> permit"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-ft-check!
-            "trusted delegate, level does NOT cover action -> deny"
-            (acl-ft-p? db (quote alice) (quote edit) (quote doc))
-            false)
-          (acl-ft-check!
-            "delegated but action class uncovered (comment has no delegate)"
-            (acl-ft-p? db (quote alice) (quote comment) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-level-covers (quote readonly) (quote read)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "untrusted peer delegate -> deny"
-          (acl-ft-p? db (quote bob) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "trust but no level_covers -> deny"
-          (acl-ft-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "trust is per-peer: alpha's delegate applies"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-ft-check!
-            "trust not transitive: beta's delegate does not apply"
-            (acl-ft-p? db (quote bob) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "local deny overrides federated grant"
-          (acl-ft-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "federated grant to group reaches member"
-          (acl-ft-p? db (quote alice) (quote read) (quote doc))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-child-of (quote sec) (quote book)) (acl-delegate (quote alpha) (quote u) (quote read) (quote book))))))
-        (acl-ft-check!
-          "federated grant on parent resource reaches child"
-          (acl-ft-p? db (quote u) (quote read) (quote sec))
-          true))
-      (let
-        ((transport {:gamma (list (acl-delegate (quote gamma) (quote carol) (quote read) (quote post))) :alpha (list (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)))}))
-        (do
-          (acl-ft-check!
-            "fetch known peer returns its delegates"
-            (len (acl-fed-fetch transport (quote alpha)))
-            1)
-          (acl-ft-check!
-            "fetch unknown peer returns empty"
-            (len (acl-fed-fetch transport (quote delta)))
-            0)
-          (acl-ft-check!
-            "collect across peers"
-            (len
-              (acl-fed-collect transport (list (quote alpha) (quote gamma))))
-            2)
-          (let
-            ((db (acl-fed-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-trust (quote gamma) (quote readonly)) (acl-level-covers (quote readonly) (quote read))) transport (list (quote alpha) (quote gamma)))))
-            (do
-              (acl-ft-check!
-                "fed-build-db: alpha delegate permits"
-                (acl-ft-p? db (quote alice) (quote read) (quote doc))
-                true)
-              (acl-ft-check!
-                "fed-build-db: gamma delegate permits"
-                (acl-ft-p? db (quote carol) (quote read) (quote post))
-                true)
-              (acl-ft-check!
-                "fed-build-db: untrusted action still denied"
-                (acl-ft-p? db (quote alice) (quote edit) (quote doc))
-                false)))))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "before revoke: permitted"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-revoke!
-            db
-            (acl-delegate
-              (quote alpha)
-              (quote alice)
-              (quote read)
-              (quote doc)))
-          (acl-ft-check!
-            "after delegate revoked: denied"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "before trust revoke: permitted"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-revoke! db (acl-trust (quote alpha) (quote full)))
-          (acl-ft-check!
-            "after trust revoked: denied"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "delegate without trust: denied"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            false)
-          (acl-fed-assert! db (acl-trust (quote alpha) (quote full)))
-          (acl-ft-check!
-            "trust ingested then re-checked: permitted"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)))
-      (let
-        ((db (acl-ft-fixture)))
-        (let
-          ((e (acl-explain db (quote alice) (quote read) (quote doc))))
-          (do
-            (acl-ft-check! "federated proof allowed?" (get e :allowed?) true)
-            (acl-ft-check!
-              "federated proof has delegate leaf"
-              (acl-ft-has-leaf?
-                (get e :proof)
-                (list
-                  (quote delegate)
-                  (quote alpha)
-                  (quote alice)
-                  (quote read)
-                  (quote doc)))
-              true)
-            (acl-ft-check!
-              "federated proof has trust leaf"
-              (acl-ft-has-leaf?
-                (get e :proof)
-                (list (quote trust) (quote alpha) (quote readonly)))
-              true)
-            (acl-ft-check!
-              "federated proof has level_covers leaf"
-              (acl-ft-has-leaf?
-                (get e :proof)
-                (list (quote level_covers) (quote readonly) (quote read)))
-              true))))
-      (acl-ft-check!
-        "schema delegate arity valid"
-        (acl-fact-valid?
-          (acl-delegate (quote p) (quote s) (quote a) (quote r)))
-        true)
-      (acl-ft-check!
-        "schema trust arity valid"
-        (acl-fact-valid? (acl-trust (quote p) (quote l)))
-        true)
-      (acl-ft-check!
-        "schema peer arity valid"
-        (acl-fact-valid? (acl-peer (quote p) (quote peer)))
-        true)
-      (acl-ft-check!
-        "schema level_covers arity valid"
-        (acl-fact-valid? (acl-level-covers (quote l) (quote read)))
-        true)
-      (acl-ft-check!
-        "schema delegate bad arity invalid"
-        (acl-fact-valid? (list (quote delegate) (quote p) (quote s)))
-        false))))
-
-(define
-  acl-fed-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-ft-pass 0)
-      (set! acl-ft-fail 0)
-      (set! acl-ft-failures (list))
-      (acl-ft-run-all!)
-      {:failures acl-ft-failures :total (+ acl-ft-pass acl-ft-fail) :passed acl-ft-pass :failed acl-ft-fail})))

lib/acl/tests/harden.sx

@@ -1,228 +0,0 @@
-;; lib/acl/tests/harden.sx — adversarial / cross-phase hardening.
-;;
-;; Diamond hierarchies, conflict resolution where deny must win through every
-;; path, chain inheritance, cycle termination, multi-peer delegation, fact
-;; validation, and audit save/restore.
-;;
-;; PROVER-FREE BY DESIGN: this suite calls only acl-permit? (which runs in
-;; compiled Datalog, safe at any depth) plus pure data ops — never acl-explain /
-;; acl-prove-d. The SX-side proof reconstructor recurses, and once the kernel
-;; JIT-compiles it (after the explain/fed suites warm the process) it loops on
-;; chains deeper than ~3 (substrate JIT bug — see plan Blockers). Proof
-;; reconstruction is covered by tests/explain.sx (and federated proofs by
-;; tests/fed.sx), both of which stay under the warm-process depth threshold.
-
-(define acl-hd-pass 0)
-(define acl-hd-fail 0)
-(define acl-hd-failures (list))
-
-(define
-  acl-hd-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! acl-hd-pass (+ acl-hd-pass 1))
-      (do
-        (set! acl-hd-fail (+ acl-hd-fail 1))
-        (append!
-          acl-hd-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define acl-hd-p? (fn (db s a r) (acl-permit? db s a r)))
-
-(define
-  acl-hd-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((grant-deny (acl-build-db (list (acl-child-of (quote r) (quote p1)) (acl-child-of (quote r) (quote p2)) (acl-grant (quote u) (quote read) (quote p1)) (acl-deny (quote u) (quote read) (quote p2)))))
-          (both-grant
-            (acl-build-db
-              (list
-                (acl-child-of (quote r) (quote p1))
-                (acl-child-of (quote r) (quote p2))
-                (acl-grant (quote u) (quote read) (quote p1))
-                (acl-grant (quote u) (quote read) (quote p2))))))
-        (do
-          (acl-hd-check!
-            "diamond resource: grant+deny parents -> deny wins"
-            (acl-hd-p? grant-deny (quote u) (quote read) (quote r))
-            false)
-          (acl-hd-check!
-            "diamond resource: both grant -> permit"
-            (acl-hd-p? both-grant (quote u) (quote read) (quote r))
-            true)
-          (acl-hd-check!
-            "diamond resource: deny does not leak to other parent"
-            (acl-hd-p? grant-deny (quote u) (quote read) (quote p1))
-            true)))
-      (let
-        ((grant-deny (acl-build-db (list (acl-member-of (quote alice) (quote g1)) (acl-member-of (quote alice) (quote g2)) (acl-grant (quote g1) (quote read) (quote doc)) (acl-deny (quote g2) (quote read) (quote doc)))))
-          (both-grant
-            (acl-build-db
-              (list
-                (acl-member-of (quote alice) (quote g1))
-                (acl-member-of (quote alice) (quote g2))
-                (acl-grant (quote g1) (quote read) (quote doc))
-                (acl-grant (quote g2) (quote read) (quote doc))))))
-        (do
-          (acl-hd-check!
-            "diamond group: grant+deny groups -> deny wins"
-            (acl-hd-p? grant-deny (quote alice) (quote read) (quote doc))
-            false)
-          (acl-hd-check!
-            "diamond group: both grant -> permit"
-            (acl-hd-p? both-grant (quote alice) (quote read) (quote doc))
-            true)))
-      (let
-        ((chain (acl-build-db (list (acl-member-of (quote a0) (quote a1)) (acl-member-of (quote a1) (quote a2)) (acl-member-of (quote a2) (quote a3)) (acl-member-of (quote a3) (quote a4)) (acl-grant (quote a4) (quote read) (quote res)))))
-          (chain-deny
-            (acl-build-db
-              (list
-                (acl-member-of (quote a0) (quote a1))
-                (acl-member-of (quote a1) (quote a2))
-                (acl-member-of (quote a2) (quote a3))
-                (acl-member-of (quote a3) (quote a4))
-                (acl-grant (quote a4) (quote read) (quote res))
-                (acl-deny (quote a0) (quote read) (quote res))))))
-        (do
-          (acl-hd-check!
-            "chain: top-group grant reaches leaf member"
-            (acl-hd-p? chain (quote a0) (quote read) (quote res))
-            true)
-          (acl-hd-check!
-            "chain: intermediate also covered"
-            (acl-hd-p? chain (quote a2) (quote read) (quote res))
-            true)
-          (acl-hd-check!
-            "chain: leaf-member deny overrides top grant"
-            (acl-hd-p? chain-deny (quote a0) (quote read) (quote res))
-            false)
-          (acl-hd-check!
-            "chain: deny on leaf does not block sibling level"
-            (acl-hd-p? chain-deny (quote a1) (quote read) (quote res))
-            true)))
-      (let
-        ((self-member (acl-build-db (list (acl-member-of (quote a) (quote a)) (acl-grant (quote a) (quote read) (quote r)))))
-          (self-child
-            (acl-build-db
-              (list
-                (acl-child-of (quote r) (quote r))
-                (acl-grant (quote u) (quote read) (quote r)))))
-          (two-cycle
-            (acl-build-db
-              (list
-                (acl-member-of (quote x) (quote y))
-                (acl-member-of (quote y) (quote x))
-                (acl-grant (quote y) (quote read) (quote r))))))
-        (do
-          (acl-hd-check!
-            "self-membership cycle terminates and grants"
-            (acl-hd-p? self-member (quote a) (quote read) (quote r))
-            true)
-          (acl-hd-check!
-            "self-child cycle terminates and grants"
-            (acl-hd-p? self-child (quote u) (quote read) (quote r))
-            true)
-          (acl-hd-check!
-            "two-node membership cycle terminates"
-            (acl-hd-p? two-cycle (quote x) (quote read) (quote r))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
-        (acl-hd-check!
-          "federated group grant, local member deny -> deny wins"
-          (acl-hd-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (acl-hd-check!
-          "two peers delegate, one trusted -> permit"
-          (acl-hd-p? db (quote bob) (quote read) (quote doc))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-trust (quote beta) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (acl-hd-check!
-          "two peers both trusted -> permit"
-          (acl-hd-p? db (quote bob) (quote read) (quote doc))
-          true))
-      (let
-        ((empty (acl-build-db (list))))
-        (acl-hd-check!
-          "empty db: nothing permitted"
-          (acl-hd-p? empty (quote u) (quote read) (quote r))
-          false))
-      (do
-        (acl-hd-check!
-          "validate: clean set has no bad facts"
-          (len
-            (acl-validate-facts
-              (list
-                (acl-grant (quote u) (quote read) (quote p))
-                (acl-member-of (quote u) (quote g))
-                (acl-delegate (quote pe) (quote u) (quote read) (quote p)))))
-          0)
-        (acl-hd-check!
-          "validate: facts-valid? true on clean set"
-          (acl-facts-valid?
-            (list (acl-grant (quote u) (quote read) (quote p))))
-          true)
-        (acl-hd-check!
-          "validate: surfaces wrong-arity and unknown predicate"
-          (len
-            (acl-validate-facts
-              (list
-                (acl-grant (quote u) (quote read) (quote p))
-                (list (quote grant) (quote u))
-                (list (quote bogus) (quote x) (quote y)))))
-          2)
-        (acl-hd-check!
-          "validate: empty set is valid"
-          (acl-facts-valid? (list))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
-        (do
-          (acl-audit-clear!)
-          (acl-audit-decide! db (quote u) (quote read) (quote p))
-          (acl-audit-decide! db (quote u) (quote edit) (quote p))
-          (let
-            ((snap (acl-audit-snapshot)))
-            (do
-              (acl-audit-clear!)
-              (acl-hd-check!
-                "audit: cleared count is 0"
-                (acl-audit-count)
-                0)
-              (acl-audit-restore! snap)
-              (acl-hd-check!
-                "audit: restored count"
-                (acl-audit-count)
-                2)
-              (acl-hd-check!
-                "audit: restored last act"
-                (get (first (acl-audit-tail 1)) :act)
-                (quote edit))
-              (acl-audit-decide! db (quote u) (quote comment) (quote p))
-              (acl-hd-check!
-                "audit: seq continues after restore"
-                (get (first (acl-audit-tail 1)) :seq)
-                2)
-              (acl-hd-check!
-                "audit: snapshot is an immutable copy"
-                (len (get snap :entries))
-                2)
-              (acl-audit-clear!))))))))
-
-(define
-  acl-harden-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-hd-pass 0)
-      (set! acl-hd-fail 0)
-      (set! acl-hd-failures (list))
-      (acl-hd-run-all!)
-      {:failures acl-hd-failures :total (+ acl-hd-pass acl-hd-fail) :passed acl-hd-pass :failed acl-hd-fail})))

lib/acl/tests/inherit.sx

@@ -1,202 +0,0 @@
-;; lib/acl/tests/inherit.sx — Phase 2: inheritance (groups, resource trees,
-;; role expansion) with deny-overrides.
-
-(define acl-it-pass 0)
-(define acl-it-fail 0)
-(define acl-it-failures (list))
-
-(define
-  acl-it-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! acl-it-pass (+ acl-it-pass 1))
-      (do
-        (set! acl-it-fail (+ acl-it-fail 1))
-        (append!
-          acl-it-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define acl-it-p? (fn (db s a r) (acl-permit? db s a r)))
-
-(define
-  acl-it-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc))))))
-        (do
-          (acl-it-check!
-            "group grant reaches member"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "group grant: non-member excluded"
-            (acl-it-p? db (quote bob) (quote read) (quote doc))
-            false)
-          (acl-it-check!
-            "group grant: wrong action"
-            (acl-it-p? db (quote alice) (quote edit) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-member-of (quote org) (quote company)) (acl-grant (quote company) (quote read) (quote doc))))))
-        (do
-          (acl-it-check!
-            "deep nested group grant reaches leaf member"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "intermediate group also covered"
-            (acl-it-p? db (quote team) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "mid group org covered"
-            (acl-it-p? db (quote org) (quote read) (quote doc))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote a) (quote b)) (acl-member-of (quote b) (quote a)) (acl-grant (quote b) (quote read) (quote r))))))
-        (do
-          (acl-it-check!
-            "cyclic membership terminates and grants"
-            (acl-it-p? db (quote a) (quote read) (quote r))
-            true)
-          (acl-it-check!
-            "cyclic membership covers both"
-            (acl-it-p? db (quote b) (quote read) (quote r))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote sec) (quote chap)) (acl-child-of (quote chap) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
-        (do
-          (acl-it-check!
-            "parent grant reaches direct child"
-            (acl-it-p? db (quote u) (quote read) (quote chap))
-            true)
-          (acl-it-check!
-            "parent grant reaches deep descendant"
-            (acl-it-p? db (quote u) (quote read) (quote sec))
-            true)
-          (acl-it-check!
-            "parent grant covers parent itself"
-            (acl-it-p? db (quote u) (quote read) (quote book))
-            true)
-          (acl-it-check!
-            "child grant does not climb to parent"
-            (acl-it-p?
-              (acl-build-db
-                (list
-                  (acl-child-of (quote sec) (quote book))
-                  (acl-grant (quote u) (quote read) (quote sec))))
-              (quote u)
-              (quote read)
-              (quote book))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-child-of (quote post1) (quote board)) (acl-grant (quote team) (quote comment) (quote board))))))
-        (do
-          (acl-it-check!
-            "group + resource: member on child resource"
-            (acl-it-p? db (quote alice) (quote comment) (quote post1))
-            true)
-          (acl-it-check!
-            "group + resource: member on parent resource"
-            (acl-it-p? db (quote alice) (quote comment) (quote board))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1)) (acl-role-grant (quote editor) (quote read) (quote page1))))))
-        (do
-          (acl-it-check!
-            "role confers edit to member"
-            (acl-it-p? db (quote bob) (quote edit) (quote page1))
-            true)
-          (acl-it-check!
-            "role confers read to member"
-            (acl-it-p? db (quote bob) (quote read) (quote page1))
-            true)
-          (acl-it-check!
-            "role: capability not in tuple denied"
-            (acl-it-p? db (quote bob) (quote moderate) (quote page1))
-            false)
-          (acl-it-check!
-            "role: non-member excluded"
-            (acl-it-p? db (quote eve) (quote edit) (quote page1))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-child-of (quote draft) (quote page1)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
-        (acl-it-check!
-          "role grant flows to child resource"
-          (acl-it-p? db (quote bob) (quote edit) (quote draft))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
-        (acl-it-check!
-          "explicit deny beats inherited group allow"
-          (acl-it-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
-        (do
-          (acl-it-check!
-            "group deny inherits and overrides direct grant"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            false)
-          (acl-it-check!
-            "group deny: another member also blocked"
-            (acl-it-p? db (quote team) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote sec)) (acl-deny (quote u) (quote read) (quote book))))))
-        (acl-it-check!
-          "ancestor deny overrides descendant grant"
-          (acl-it-p? db (quote u) (quote read) (quote sec))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-grant (quote team) (quote edit) (quote doc)) (acl-deny (quote alice) (quote edit) (quote doc))))))
-        (do
-          (acl-it-check!
-            "deny on edit leaves inherited read intact"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "deny on edit blocks edit"
-            (acl-it-p? db (quote alice) (quote edit) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-deny (quote team) (quote read) (quote doc))))))
-        (acl-it-check!
-          "inherited deny, no grant: denied"
-          (acl-it-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote a) (quote root)) (acl-child-of (quote b) (quote root)) (acl-grant (quote u) (quote read) (quote root)) (acl-deny (quote u) (quote read) (quote a))))))
-        (do
-          (acl-it-check!
-            "deny on sibling a blocks a"
-            (acl-it-p? db (quote u) (quote read) (quote a))
-            false)
-          (acl-it-check!
-            "deny on sibling a leaves b permitted"
-            (acl-it-p? db (quote u) (quote read) (quote b))
-            true)
-          (acl-it-check!
-            "root itself still permitted"
-            (acl-it-p? db (quote u) (quote read) (quote root))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote x) (quote read) (quote y))))))
-        (acl-it-check!
-          "direct grant under inheritance ruleset"
-          (acl-it-p? db (quote x) (quote read) (quote y))
-          true)))))
-
-(define
-  acl-inherit-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-it-pass 0)
-      (set! acl-it-fail 0)
-      (set! acl-it-failures (list))
-      (acl-it-run-all!)
-      {:failures acl-it-failures :total (+ acl-it-pass acl-it-fail) :passed acl-it-pass :failed acl-it-fail})))

lib/artdag/analyze.sx

@@ -1,88 +0,0 @@
-; lib/artdag/analyze.sx — Phase 2: Analyze on Datalog.
-; Project the DAG's edges into a Datalog db and answer dependency questions
-; (deps, dependents, transitive reachability) plus dirty-closure propagation
-; as recursive Datalog — the acl/relations reachability shape. Depends on
-; lib/artdag/dag.sx and the lib/datalog/ public API.
-
-; edge(input-id, node-id): data flows input -> node (input is a dependency).
-(define
-  artdag/edge-facts
-  (fn
-    (dag)
-    (reduce
-      (fn
-        (acc id)
-        (concat
-          acc
-          (map
-            (fn (in) (list (quote edge) in id))
-            (artdag/node-inputs (artdag/dag-get dag id)))))
-      (list)
-      (keys (artdag/dag-nodes dag)))))
-
-; reachable(X,Y): Y is a transitive dependent of X (forward, downstream).
-(define
-  artdag/reach-rules
-  (quote
-    ((reachable X Y <- (edge X Y))
-      (reachable X Z <- (edge X Y) (reachable Y Z)))))
-
-(define
-  artdag/analyze
-  (fn (dag) (dl-program-data (artdag/edge-facts dag) artdag/reach-rules)))
-
-; pull a single variable's bindings out of a subst list, sorted for determinism.
-(define
-  artdag/-bindings
-  (fn
-    (substs var)
-    (artdag/sort-strings (map (fn (s) (get s var)) substs))))
-
-; direct dependencies (inputs) of a node.
-(define
-  artdag/deps-of
-  (fn
-    (db id)
-    (artdag/-bindings (dl-query db (list (quote edge) (quote X) id)) :X)))
-
-; direct dependents of a node.
-(define
-  artdag/dependents-of
-  (fn
-    (db id)
-    (artdag/-bindings (dl-query db (list (quote edge) id (quote Y))) :Y)))
-
-; transitive dependents (everything downstream of a node).
-(define
-  artdag/reachable-from
-  (fn
-    (db id)
-    (artdag/-bindings
-      (dl-query db (list (quote reachable) id (quote Y)))
-      :Y)))
-
-; transitive dependencies (everything upstream of a node).
-(define
-  artdag/ancestors-of
-  (fn
-    (db id)
-    (artdag/-bindings
-      (dl-query db (list (quote reachable) (quote X) id))
-      :X)))
-
-; dirty propagation: dirty(Y) :- edge(X,Y), dirty(X). Seeds are changed nodes.
-(define artdag/dirty-rules (quote ((dirty Y <- (edge X Y) (dirty X)))))
-
-(define
-  artdag/dirty-seeds
-  (fn (changed) (map (fn (c) (list (quote dirty) c)) changed)))
-
-; transitive dirty closure of a set of changed node-ids: the changed nodes plus
-; every transitive dependent that must recompute. Sorted, deduplicated.
-(define
-  artdag/dirty-closure
-  (fn
-    (dag changed)
-    (let
-      ((db (dl-program-data (concat (artdag/edge-facts dag) (artdag/dirty-seeds changed)) artdag/dirty-rules)))
-      (artdag/-bindings (dl-query db (list (quote dirty) (quote X))) :X))))

lib/artdag/api.sx

@@ -1,91 +0,0 @@
-; lib/artdag/api.sx — public API index for the artdag content-addressed dataflow
-; DAG engine. Reference-only: `load` is an epoch-protocol command, not an SX
-; function, so this file cannot reload the modules from inside another `.sx`. To
-; set up a session, issue these loads in order (after spec/stdlib.sx + lib/r7rs.sx,
-; the lib/datalog/* modules, and the lib/persist/* modules):
-;
-;   (load "lib/artdag/dag.sx")
-;   (load "lib/artdag/analyze.sx")      ; requires lib/datalog/*
-;   (load "lib/artdag/plan.sx")
-;   (load "lib/artdag/execute.sx")      ; requires lib/persist/*
-;   (load "lib/artdag/optimize.sx")
-;   (load "lib/artdag/federation.sx")
-;   (load "lib/artdag/cost.sx")
-;   (load "lib/artdag/serialize.sx")
-;   (load "lib/artdag/stats.sx")
-;   (load "lib/artdag/fault.sx")
-;
-; (lib/artdag/conformance.sh runs this load list automatically.)
-;
-; ── Public API surface ─────────────────────────────────────────────
-;
-;   Model / content addressing (dag.sx):
-;     (artdag/node op inputs params)        node spec (non-commutative)
-;     (artdag/cnode op inputs params)       commutative node spec
-;     (artdag/content-id node)              structural digest "node:..."
-;     (artdag/build entries)                {:ok :nodes :names :order} | {:ok false :error}
-;       entry = (name op (input-names...) params [commutative?])
-;     (artdag/dag-id dag name)              local name -> content-id
-;     (artdag/dag-get dag id)               content-id -> node
-;     (artdag/dag-node-by-name dag name)    name -> node
-;     (artdag/dag-order dag)                topo-ordered content-ids
-;     (artdag/node-count dag)               distinct node count
-;
-;   Analyze on Datalog (analyze.sx):
-;     (artdag/analyze dag)                  -> datalog db
-;     (artdag/deps-of db id)                direct dependencies
-;     (artdag/dependents-of db id)          direct dependents
-;     (artdag/reachable-from db id)         transitive dependents
-;     (artdag/ancestors-of db id)           transitive dependencies
-;     (artdag/dirty-closure dag changed)    changed nodes + all dependents
-;
-;   Plan (plan.sx):
-;     (artdag/plan dag cap)                 topo batches under width cap (0 = unlimited)
-;     (artdag/plan-dirty dag changed cap)   incremental plan over the dirty closure
-;     (artdag/plan-batches/-width/-size/-flatten plan)
-;
-;   Execute (execute.sx):
-;     (artdag/op-table-runner table)        runner from op-name -> (fn (params inputs))
-;     (artdag/run dag runner cache)         full memoized run
-;     (artdag/run-dirty dag changed runner cache)
-;     (artdag/execute dag plan runner cache) -> {:results :recomputed :hits}
-;     (artdag/result-of/recompute-count/hit-count/recomputed exec)
-;       cache = a lib/persist kv backend (persist/open)
-;
-;   Optimize (optimize.sx):
-;     (artdag/dce dag outputs)              drop nodes not feeding the outputs
-;     (artdag/cse entries)                  == build (sharing is free from content ids)
-;     (artdag/fuse entries fusible?)        collapse fusible unary chains -> pipeline nodes
-;     (artdag/fusing-runner base-runner)    runner that replays pipeline stages
-;     (artdag/optimize entries outputs fusible?)  fuse then dce
-;
-;   Federation (federation.sx):
-;     (artdag/fed-open)                     {:cache :prov}
-;     (artdag/fed-run fed dag runner)       run against the instance cache
-;     (artdag/fed-export fed peer-id)       bundle of {:cid :result :peer}
-;     (artdag/fed-import fed bundle trusted?)  trust-gated import + provenance
-;     (artdag/fed-pull fed fetch-fn peer-id trusted?)  pull via injected transport
-;     (artdag/fed-invalidate fed peer-id)   drop a peer's results (peer-scoped)
-;
-;   Cost / scheduling (cost.sx):
-;     (artdag/const-cost) (artdag/op-cost table)   cost-fn (op params) -> number
-;     (artdag/critical-path dag cost-fn)    longest weighted path
-;     (artdag/makespan dag plan cost-fn)    estimated wall-clock under a plan
-;     (artdag/total-work dag cost-fn) (artdag/speedup dag plan cost-fn)
-;
-;   Serialize (serialize.sx):
-;     (artdag/dag->wire dag) (artdag/wire->dag records)  portable record form
-;     (artdag/wire-verify records)          content-id integrity check
-;     (artdag/dag->string dag) (artdag/string->dag s)    text transport
-;
-;   Stats (stats.sx):
-;     (artdag/hit-ratio exec)
-;     (artdag/work-recomputed/work-saved exec dag cost-fn)
-;     (artdag/savings-ratio exec dag cost-fn) (artdag/exec-summary exec dag cost-fn)
-;
-;   Fault tolerance (fault.sx):
-;     (artdag/fail reason) (artdag/failed? v)
-;     (artdag/run-safe dag runner cache)    -> {:results :recomputed :hits :failed}
-;     (artdag/failed-nodes/failure-count/all-ok? exec)
-
-(define artdag/version "1.0")

lib/artdag/conformance.sh

@@ -1,131 +0,0 @@
-#!/usr/bin/env bash
-# lib/artdag/conformance.sh — run artdag test suites, emit scoreboard.json + scoreboard.md.
-
-set -uo pipefail
-cd "$(git rev-parse --show-toplevel)"
-
-SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
-if [ ! -x "$SX_SERVER" ]; then
-  SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
-fi
-if [ ! -x "$SX_SERVER" ]; then
-  echo "ERROR: sx_server.exe not found." >&2
-  exit 1
-fi
-
-SUITES=(dag analyze plan execute optimize fed cost serialize stats fault)
-
-OUT_JSON="lib/artdag/scoreboard.json"
-OUT_MD="lib/artdag/scoreboard.md"
-
-run_suite() {
-  local suite=$1
-  local file="lib/artdag/tests/${suite}.sx"
-  local TMP
-  TMP=$(mktemp)
-  cat > "$TMP" << EPOCHS
-(epoch 1)
-(load "spec/stdlib.sx")
-(load "lib/r7rs.sx")
-(load "lib/datalog/tokenizer.sx")
-(load "lib/datalog/parser.sx")
-(load "lib/datalog/unify.sx")
-(load "lib/datalog/db.sx")
-(load "lib/datalog/builtins.sx")
-(load "lib/datalog/aggregates.sx")
-(load "lib/datalog/strata.sx")
-(load "lib/datalog/eval.sx")
-(load "lib/datalog/api.sx")
-(load "lib/persist/event.sx")
-(load "lib/persist/backend.sx")
-(load "lib/persist/log.sx")
-(load "lib/persist/kv.sx")
-(load "lib/persist/api.sx")
-(load "lib/artdag/dag.sx")
-(load "lib/artdag/analyze.sx")
-(load "lib/artdag/plan.sx")
-(load "lib/artdag/execute.sx")
-(load "lib/artdag/optimize.sx")
-(load "lib/artdag/federation.sx")
-(load "lib/artdag/cost.sx")
-(load "lib/artdag/serialize.sx")
-(load "lib/artdag/stats.sx")
-(load "lib/artdag/fault.sx")
-(load "lib/artdag/api.sx")
-(epoch 2)
-(eval "(define artdag-test-pass 0)")
-(eval "(define artdag-test-fail 0)")
-(eval "(define artdag-test (fn (name got expected) (if (= got expected) (set! artdag-test-pass (+ artdag-test-pass 1)) (set! artdag-test-fail (+ artdag-test-fail 1)))))")
-(epoch 3)
-(load "${file}")
-(epoch 4)
-(eval "(list artdag-test-pass artdag-test-fail)")
-EPOCHS
-
-  local OUTPUT
-  OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null)
-  rm -f "$TMP"
-
-  local LINE
-  LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
-  if [ -z "$LINE" ]; then
-    LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
-            | sed -E 's/^\(ok 4 //; s/\)$//')
-  fi
-
-  local P F
-  P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
-  F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
-  P=${P:-0}
-  F=${F:-0}
-  echo "${P} ${F}"
-}
-
-declare -A SUITE_PASS
-declare -A SUITE_FAIL
-TOTAL_PASS=0
-TOTAL_FAIL=0
-
-echo "Running artdag conformance suite..." >&2
-for s in "${SUITES[@]}"; do
-  read -r p f < <(run_suite "$s")
-  SUITE_PASS[$s]=$p
-  SUITE_FAIL[$s]=$f
-  TOTAL_PASS=$((TOTAL_PASS + p))
-  TOTAL_FAIL=$((TOTAL_FAIL + f))
-  printf "  %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
-done
-
-{
-  printf '{\n'
-  printf '  "suites": {\n'
-  first=1
-  for s in "${SUITES[@]}"; do
-    if [ $first -eq 0 ]; then printf ',\n'; fi
-    printf '    "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
-    first=0
-  done
-  printf '\n  },\n'
-  printf '  "total_pass": %d,\n' "$TOTAL_PASS"
-  printf '  "total_fail": %d,\n' "$TOTAL_FAIL"
-  printf '  "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
-  printf '}\n'
-} > "$OUT_JSON"
-
-{
-  printf '# artdag Conformance Scoreboard\n\n'
-  printf '_Generated by `lib/artdag/conformance.sh`_\n\n'
-  printf '| Suite | Pass | Fail | Total |\n'
-  printf '|-------|-----:|-----:|------:|\n'
-  for s in "${SUITES[@]}"; do
-    p=${SUITE_PASS[$s]}
-    f=${SUITE_FAIL[$s]}
-    printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
-  done
-  printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
-} > "$OUT_MD"
-
-echo "Wrote $OUT_JSON and $OUT_MD" >&2
-echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
-
-[ "$TOTAL_FAIL" -eq 0 ]

lib/artdag/cost.sx

@@ -1,66 +0,0 @@
-; lib/artdag/cost.sx — cost model for the scheduler: per-node weights, critical
-; path (min makespan with unlimited parallelism), plan makespan under batching/cap,
-; total serial work, and the resulting speedup. Costs come from an injected
-; cost-fn (op params) -> number so media-op costs stay opaque. Depends on dag.sx.
-
-(define artdag/const-cost (fn (op params) 1))
-
-(define
-  artdag/op-cost
-  (fn
-    (table)
-    (fn (op params) (if (has-key? table op) (get table op) 1))))
-
-(define
-  artdag/-node-cost
-  (fn
-    (dag cost-fn id)
-    (let
-      ((n (artdag/dag-get dag id)))
-      (cost-fn (artdag/node-op n) (artdag/node-params n)))))
-
-(define
-  artdag/-max
-  (fn (xs) (reduce (fn (mx x) (if (> x mx) x mx)) 0 xs)))
-
-; longest weighted path through the dag = makespan with unlimited workers.
-(define
-  artdag/critical-path
-  (fn
-    (dag cost-fn)
-    (let
-      ((ft (reduce (fn (m id) (let ((maxdep (artdag/-max (map (fn (d) (get m d)) (artdag/node-inputs (artdag/dag-get dag id)))))) (assoc m id (+ (artdag/-node-cost dag cost-fn id) maxdep)))) {} (artdag/dag-order dag))))
-      (artdag/-max (map (fn (id) (get ft id)) (keys ft))))))
-
-; estimated wall-clock for a plan: each batch runs in parallel (costs its
-; slowest node), batches run in sequence.
-(define
-  artdag/makespan
-  (fn
-    (dag plan cost-fn)
-    (reduce
-      (fn
-        (total batch)
-        (+
-          total
-          (artdag/-max
-            (map (fn (id) (artdag/-node-cost dag cost-fn id)) batch))))
-      0
-      plan)))
-
-; total serial work = sum of all node costs.
-(define
-  artdag/total-work
-  (fn
-    (dag cost-fn)
-    (reduce
-      (fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
-      0
-      (keys (artdag/dag-nodes dag)))))
-
-; speedup of a plan vs running everything serially.
-(define
-  artdag/speedup
-  (fn
-    (dag plan cost-fn)
-    (/ (artdag/total-work dag cost-fn) (artdag/makespan dag plan cost-fn))))

lib/artdag/dag.sx

@@ -1,226 +0,0 @@
-; lib/artdag/dag.sx — DAG model + structural content addressing.
-; A node = {:op :inputs :params :commutative}. inputs are content-ids of upstream
-; nodes. The content-id is a deterministic structural digest so identical
-; subgraphs collapse to one id (and one cache slot). No clock, no randomness.
-
-; ---- string ordering (no host sort/string<?) ----
-
-(define
-  artdag/str<?-at
-  (fn
-    (a b i la lb)
-    (cond
-      ((and (>= i la) (>= i lb)) false)
-      ((>= i la) true)
-      ((>= i lb) false)
-      (else
-        (let
-          ((ca (char-code (substring a i (+ i 1))))
-            (cb (char-code (substring b i (+ i 1)))))
-          (cond
-            ((< ca cb) true)
-            ((> ca cb) false)
-            (else (artdag/str<?-at a b (+ i 1) la lb))))))))
-
-(define
-  artdag/str<?
-  (fn
-    (a b)
-    (artdag/str<?-at a b 0 (string-length a) (string-length b))))
-
-(define
-  artdag/insert-string
-  (fn
-    (sorted x)
-    (cond
-      ((empty? sorted) (list x))
-      ((artdag/str<? x (first sorted)) (cons x sorted))
-      (else (cons (first sorted) (artdag/insert-string (rest sorted) x))))))
-
-(define
-  artdag/sort-strings
-  (fn (xs) (reduce (fn (acc x) (artdag/insert-string acc x)) (list) xs)))
-
-; ---- canonical serialization ----
-
-(define
-  artdag/canon-list
-  (fn
-    (xs)
-    (if
-      (empty? xs)
-      ""
-      (reduce
-        (fn (acc x) (str acc " " (artdag/canon x)))
-        (artdag/canon (first xs))
-        (rest xs)))))
-
-(define
-  artdag/canon-dict
-  (fn
-    (d)
-    (str
-      "{"
-      (reduce
-        (fn (acc k) (str acc " " k "=" (artdag/canon (get d k))))
-        ""
-        (artdag/sort-strings (keys d)))
-      "}")))
-
-(define
-  artdag/canon
-  (fn
-    (v)
-    (let
-      ((t (type-of v)))
-      (cond
-        ((equal? t "nil") "nil")
-        ((equal? t "boolean") (if v "#t" "#f"))
-        ((equal? t "number") (number->string v))
-        ((equal? t "string") (str "\"" v "\""))
-        ((equal? t "keyword") (str ":" (keyword-name v)))
-        ((equal? t "symbol") (str "'" (write-to-string v)))
-        ((equal? t "list") (str "(" (artdag/canon-list v) ")"))
-        ((equal? t "dict") (artdag/canon-dict v))
-        (else (str "<" t ">" (write-to-string v)))))))
-
-; ---- node + content id ----
-
-(define artdag/node (fn (op inputs params) {:inputs inputs :commutative false :op op :params params}))
-
-(define artdag/cnode (fn (op inputs params) {:inputs inputs :commutative true :op op :params params}))
-
-(define artdag/node-op (fn (n) (get n :op)))
-(define artdag/node-inputs (fn (n) (get n :inputs)))
-(define artdag/node-params (fn (n) (get n :params)))
-
-(define
-  artdag/content-id
-  (fn
-    (node)
-    (let
-      ((ins (if (get node :commutative) (artdag/sort-strings (get node :inputs)) (get node :inputs))))
-      (str
-        "node:"
-        (artdag/canon (list (get node :op) ins (get node :params)))))))
-
-(define artdag/id-of artdag/content-id)
-
-; ---- list helpers ----
-
-(define artdag/member? (fn (x xs) (some (fn (y) (equal? y x)) xs)))
-
-(define
-  artdag/all-in?
-  (fn (xs placed) (every? (fn (x) (artdag/member? x placed)) xs)))
-
-; ---- build: entries -> validated, content-addressed dag ----
-; entry = (local-name op (input-local-names...) params [commutative?])
-
-(define artdag/entry-name (fn (e) (nth e 0)))
-(define artdag/entry-op (fn (e) (nth e 1)))
-(define artdag/entry-inputs (fn (e) (nth e 2)))
-(define artdag/entry-params (fn (e) (nth e 3)))
-(define
-  artdag/entry-commutative
-  (fn (e) (if (> (len e) 4) (nth e 4) false)))
-
-(define
-  artdag/entries->map
-  (fn
-    (entries)
-    (reduce
-      (fn (m e) (assoc m (artdag/entry-name e) {:inputs (artdag/entry-inputs e) :commutative (artdag/entry-commutative e) :op (artdag/entry-op e) :params (artdag/entry-params e)}))
-      {}
-      entries)))
-
-(define
-  artdag/dangling
-  (fn
-    (spec-map)
-    (reduce
-      (fn
-        (acc name)
-        (reduce
-          (fn (a in) (if (has-key? spec-map in) a (cons in a)))
-          acc
-          (get (get spec-map name) :inputs)))
-      (list)
-      (keys spec-map))))
-
-(define
-  artdag/ready-names
-  (fn
-    (spec-map placed)
-    (filter
-      (fn
-        (name)
-        (and
-          (not (artdag/member? name placed))
-          (artdag/all-in? (get (get spec-map name) :inputs) placed)))
-      (artdag/sort-strings (keys spec-map)))))
-
-(define
-  artdag/topo-loop
-  (fn
-    (spec-map placed)
-    (if
-      (= (len placed) (len (keys spec-map)))
-      {:order placed :ok true}
-      (let
-        ((ready (artdag/ready-names spec-map placed)))
-        (if
-          (empty? ready)
-          {:error "cycle" :ok false}
-          (artdag/topo-loop spec-map (concat placed ready)))))))
-
-(define artdag/topo (fn (spec-map) (artdag/topo-loop spec-map (list))))
-
-(define
-  artdag/resolve-ids
-  (fn
-    (spec-map order)
-    (reduce
-      (fn
-        (dag name)
-        (let
-          ((spec (get spec-map name)))
-          (let
-            ((resolved (map (fn (in) (get (get dag :names) in)) (get spec :inputs))))
-            (let
-              ((node {:inputs resolved :commutative (get spec :commutative) :op (get spec :op) :params (get spec :params)}))
-              (let ((id (artdag/content-id node))) {:names (assoc (get dag :names) name id) :order (if (artdag/member? id (get dag :order)) (get dag :order) (concat (get dag :order) (list id))) :nodes (assoc (get dag :nodes) id node)})))))
-      {:names {} :order (list) :nodes {}}
-      order)))
-
-(define
-  artdag/build
-  (fn
-    (entries)
-    (let
-      ((spec-map (artdag/entries->map entries)))
-      (let
-        ((dang (artdag/dangling spec-map)))
-        (if
-          (not (empty? dang))
-          {:refs dang :error "dangling" :ok false}
-          (let
-            ((topo (artdag/topo spec-map)))
-            (if
-              (not (get topo :ok))
-              {:error (get topo :error) :ok false}
-              (assoc
-                (artdag/resolve-ids spec-map (get topo :order))
-                :ok true))))))))
-
-; ---- dag accessors ----
-
-(define artdag/dag-nodes (fn (dag) (get dag :nodes)))
-(define artdag/dag-names (fn (dag) (get dag :names)))
-(define artdag/dag-order (fn (dag) (get dag :order)))
-(define artdag/dag-id (fn (dag name) (get (get dag :names) name)))
-(define artdag/dag-get (fn (dag id) (get (get dag :nodes) id)))
-(define
-  artdag/dag-node-by-name
-  (fn (dag name) (artdag/dag-get dag (artdag/dag-id dag name))))
-(define artdag/node-count (fn (dag) (len (keys (get dag :nodes)))))

lib/artdag/execute.sx

@@ -1,82 +0,0 @@
-; lib/artdag/execute.sx — Phase 4: interpret a plan with a content-addressed
-; memo cache. A node's result is keyed by its content-id, so a node whose id is
-; already in the cache is skipped (cache hit). Because changing a leaf changes
-; the content-ids of its whole dirty closure, re-running recomputes exactly those
-; nodes and cache-hits the rest — incremental recompute falls out of content
-; addressing. Depends on dag.sx and plan.sx; the cache is a lib/persist/ backend.
-
-; runner: (fn (op params input-results) -> result). The injected effect interface.
-; In production this performs the op (perform -> JAX/IPFS adapter); in tests it
-; dispatches a pure SX op over its already-computed input results.
-
-; build a runner from a dict of op-name -> (fn (params inputs) -> result).
-(define
-  artdag/op-table-runner
-  (fn (table) (fn (op params inputs) ((get table op) params inputs))))
-
-; resolve an input id's result: this run's results first, then the warm cache.
-(define
-  artdag/-input-result
-  (fn
-    (results cache in)
-    (if (has-key? results in) (get results in) (persist/kv-get cache in))))
-
-(define
-  artdag/-exec-node
-  (fn
-    (dag runner cache acc id)
-    (let
-      ((node (artdag/dag-get dag id)))
-      (if
-        (persist/kv-has? cache id)
-        (assoc
-          acc
-          :results (assoc (get acc :results) id (persist/kv-get cache id))
-          :hits (concat (get acc :hits) (list id)))
-        (let
-          ((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) (artdag/node-inputs node))))
-          (let
-            ((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
-            (begin
-              (persist/kv-put cache id result)
-              (assoc
-                acc
-                :results (assoc (get acc :results) id result)
-                :recomputed (concat (get acc :recomputed) (list id))))))))))
-
-; execute a plan against a memo cache, returning {:results :recomputed :hits}.
-(define
-  artdag/execute
-  (fn
-    (dag plan runner cache)
-    (reduce
-      (fn (acc id) (artdag/-exec-node dag runner cache acc id))
-      {:recomputed (list) :results {} :hits (list)}
-      (artdag/plan-flatten plan))))
-
-; full run over every node, unlimited width.
-(define
-  artdag/run
-  (fn
-    (dag runner cache)
-    (artdag/execute dag (artdag/plan dag 0) runner cache)))
-
-; incremental run: schedule only the dirty closure of the changed nodes.
-(define
-  artdag/run-dirty
-  (fn
-    (dag changed runner cache)
-    (artdag/execute
-      dag
-      (artdag/plan-dirty dag changed 0)
-      runner
-      cache)))
-
-; ---- result inspection ----
-
-(define artdag/result-of (fn (exec id) (get (get exec :results) id)))
-(define
-  artdag/recomputed
-  (fn (exec) (artdag/sort-strings (get exec :recomputed))))
-(define artdag/recompute-count (fn (exec) (len (get exec :recomputed))))
-(define artdag/hit-count (fn (exec) (len (get exec :hits))))

lib/artdag/fault.sx

@@ -1,56 +0,0 @@
-; lib/artdag/fault.sx — fault-tolerant execution. A node op may fail by returning
-; (artdag/fail reason); the failure is confined to that node and its transitive
-; dependents (which cannot run without it), while independent branches still
-; compute. Failed results are NEVER cached, so a later run with the fault fixed
-; recomputes only the failed closure. Depends on execute.sx and plan.sx.
-
-(define artdag/fail (fn (reason) {:artdag-fail true :reason reason}))
-(define artdag/failed? (fn (v) (and (dict? v) (has-key? v :artdag-fail))))
-
-(define
-  artdag/-exec-safe-node
-  (fn
-    (dag runner cache acc id)
-    (let
-      ((node (artdag/dag-get dag id)))
-      (let
-        ((ins (artdag/node-inputs node)))
-        (if
-          (some (fn (in) (artdag/member? in (get acc :failed))) ins)
-          (assoc acc :failed (concat (get acc :failed) (list id)))
-          (if
-            (persist/kv-has? cache id)
-            (assoc
-              acc
-              :results (assoc (get acc :results) id (persist/kv-get cache id))
-              :hits (concat (get acc :hits) (list id)))
-            (let
-              ((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) ins)))
-              (let
-                ((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
-                (if
-                  (artdag/failed? result)
-                  (assoc acc :failed (concat (get acc :failed) (list id)))
-                  (begin
-                    (persist/kv-put cache id result)
-                    (assoc
-                      acc
-                      :results (assoc (get acc :results) id result)
-                      :recomputed (concat (get acc :recomputed) (list id)))))))))))))
-
-(define
-  artdag/run-safe
-  (fn
-    (dag runner cache)
-    (reduce
-      (fn (acc id) (artdag/-exec-safe-node dag runner cache acc id))
-      {:recomputed (list) :results {} :hits (list) :failed (list)}
-      (artdag/plan-flatten (artdag/plan dag 0)))))
-
-(define
-  artdag/failed-nodes
-  (fn (exec) (artdag/sort-strings (get exec :failed))))
-(define artdag/failure-count (fn (exec) (len (get exec :failed))))
-(define
-  artdag/all-ok?
-  (fn (exec) (= (len (get exec :failed)) 0)))

lib/artdag/federation.sx

@@ -1,75 +0,0 @@
-; lib/artdag/federation.sx — Phase 6: shared content-addressed cache across
-; instances (the L2-registry analog). Because content-ids are global, a result
-; computed on one instance is reusable on another by id. Imports are trust-gated
-; and carry provenance so a peer's results can be invalidated when trust is
-; withdrawn. Transport is injected (mock in tests). Depends on dag.sx, execute.sx
-; (the cache is a lib/persist/ kv backend) — federation tracks provenance beside it.
-
-; an instance: a persist kv cache + a provenance map {cid -> origin-peer}.
-(define artdag/fed-open (fn () {:cache (persist/open) :prov {}}))
-(define artdag/fed-cache (fn (fed) (get fed :cache)))
-(define artdag/fed-prov (fn (fed) (get fed :prov)))
-
-(define
-  artdag/-dict-remove
-  (fn
-    (d key)
-    (reduce
-      (fn (acc k) (if (= k key) acc (assoc acc k (get d k))))
-      {}
-      (keys d))))
-
-; export every cached result as a bundle of {:cid :result :peer}, tagged with
-; the exporting instance's peer id (the result's origin/provenance).
-(define
-  artdag/fed-export
-  (fn
-    (fed peer-id)
-    (map (fn (cid) {:peer peer-id :cid cid :result (persist/kv-get (get fed :cache) cid)}) (persist/kv-keys (get fed :cache)))))
-
-; import a bundle, accepting only records from trusted peers (trust gating) and
-; recording each accepted result's provenance. Returns the updated instance.
-(define
-  artdag/fed-import
-  (fn
-    (fed bundle trusted?)
-    (reduce
-      (fn
-        (f rec)
-        (if
-          (trusted? (get rec :peer))
-          (begin
-            (persist/kv-put (get f :cache) (get rec :cid) (get rec :result))
-            {:cache (get f :cache) :prov (assoc (get f :prov) (get rec :cid) (get rec :peer))})
-          f))
-      fed
-      bundle)))
-
-; pull from a peer through an injected transport (fetch-fn peer-id -> bundle).
-(define
-  artdag/fed-pull
-  (fn
-    (fed fetch-fn peer-id trusted?)
-    (artdag/fed-import fed (fetch-fn peer-id) trusted?)))
-
-; invalidate: drop every cached result provenanced to a peer (trust withdrawn),
-; from both the cache and the provenance map. Locally-computed results (no
-; provenance) are untouched. Returns the updated instance.
-(define
-  artdag/fed-invalidate
-  (fn
-    (fed peer-id)
-    (reduce
-      (fn
-        (f cid)
-        (if
-          (= (get (get f :prov) cid) peer-id)
-          (begin (persist/kv-delete (get f :cache) cid) {:cache (get f :cache) :prov (artdag/-dict-remove (get f :prov) cid)})
-          f))
-      fed
-      (keys (get fed :prov)))))
-
-; convenience: run a dag against an instance's cache.
-(define
-  artdag/fed-run
-  (fn (fed dag runner) (artdag/run dag runner (artdag/fed-cache fed))))

lib/artdag/optimize.sx

@@ -1,202 +0,0 @@
-; lib/artdag/optimize.sx — Phase 5: result-preserving DAG rewrites.
-;   DCE    — drop nodes not reachable upstream from the requested outputs.
-;   CSE    — free from content addressing: structurally identical subexpressions
-;            already collapse to one node at build time (artdag/cse == build).
-;   Fusion — collapse a maximal 1-to-1 chain of fusible unary ops into a single
-;            "artdag/pipeline" node that replays the stages; output-equivalent.
-;   optimize — fuse then DCE in one pass.
-; Depends on dag.sx and analyze.sx.
-
-; ---- dict helper ----
-
-(define
-  artdag/-dict-filter
-  (fn
-    (d keep?)
-    (reduce
-      (fn (acc k) (if (keep? k (get d k)) (assoc acc k (get d k)) acc))
-      {}
-      (keys d))))
-
-(define
-  artdag/-union
-  (fn
-    (a b)
-    (reduce (fn (acc x) (if (artdag/member? x acc) acc (cons x acc))) a b)))
-
-; ---- dead-node elimination ----
-; keep only the outputs and their transitive dependencies; ids are preserved.
-(define
-  artdag/dce
-  (fn
-    (dag outputs)
-    (let
-      ((db (artdag/analyze dag)))
-      (let
-        ((live (reduce (fn (acc out) (artdag/-union (artdag/-union acc (list out)) (artdag/ancestors-of db out))) (list) outputs)))
-        {:names (artdag/-dict-filter (artdag/dag-names dag) (fn (k v) (artdag/member? v live))) :order (filter (fn (id) (artdag/member? id live)) (artdag/dag-order dag)) :ok true :nodes (artdag/-dict-filter (artdag/dag-nodes dag) (fn (k v) (artdag/member? k live)))}))))
-
-; ---- common-subexpression elimination ----
-; structural sharing is inherent to content addressing: build already maps
-; structurally identical specs to a single node/id.
-(define artdag/cse artdag/build)
-
-; ---- adjacent-op fusion (entry-level rewrite) ----
-
-(define artdag/pipeline-op "artdag/pipeline")
-
-(define
-  artdag/-name->entry
-  (fn
-    (entries)
-    (reduce
-      (fn (m e) (assoc m (artdag/entry-name e) e))
-      {}
-      entries)))
-
-; name -> list of dependent names
-(define
-  artdag/-deps-map
-  (fn
-    (entries)
-    (reduce
-      (fn
-        (m e)
-        (reduce
-          (fn
-            (mm i)
-            (assoc
-              mm
-              i
-              (cons
-                (artdag/entry-name e)
-                (if (has-key? mm i) (get mm i) (list)))))
-          m
-          (artdag/entry-inputs e)))
-      {}
-      entries)))
-
-(define artdag/-stage (fn (e) {:op (artdag/entry-op e) :params (artdag/entry-params e)}))
-
-; the single predecessor that `name` may absorb, or nil. Requires: name is a
-; fusible unary op; its one input is a locally-defined fusible node whose ONLY
-; dependent is name (so fusing cannot break sharing).
-(define
-  artdag/-absorbs
-  (fn
-    (n->e deps fusible? name)
-    (let
-      ((e (get n->e name)))
-      (let
-        ((ins (artdag/entry-inputs e)))
-        (if
-          (= (len ins) 1)
-          (let
-            ((x (first ins)))
-            (if
-              (and
-                (has-key? n->e x)
-                (fusible? (artdag/entry-op e))
-                (fusible? (artdag/entry-op (get n->e x)))
-                (= (get deps x) (list name)))
-              x
-              nil))
-          nil)))))
-
-(define
-  artdag/-absorbed-set
-  (fn
-    (n->e deps fusible? names)
-    (reduce
-      (fn
-        (acc y)
-        (let
-          ((p (artdag/-absorbs n->e deps fusible? y)))
-          (if (nil? p) acc (cons p acc))))
-      (list)
-      names)))
-
-; walk predecessors from a tail, building stages head->tail.
-(define
-  artdag/-fuse-chain
-  (fn
-    (n->e deps fusible? cur stages)
-    (let
-      ((p (artdag/-absorbs n->e deps fusible? cur)))
-      (if
-        (nil? p)
-        {:stages (cons (artdag/-stage (get n->e cur)) stages) :head cur}
-        (artdag/-fuse-chain
-          n->e
-          deps
-          fusible?
-          p
-          (cons (artdag/-stage (get n->e cur)) stages))))))
-
-(define
-  artdag/fuse-entries
-  (fn
-    (entries fusible?)
-    (let
-      ((n->e (artdag/-name->entry entries))
-        (deps (artdag/-deps-map entries))
-        (names (map artdag/entry-name entries)))
-      (let
-        ((absorbed (artdag/-absorbed-set n->e deps fusible? names)))
-        (map
-          (fn
-            (name)
-            (let
-              ((c (artdag/-fuse-chain n->e deps fusible? name (list))))
-              (if
-                (> (len (get c :stages)) 1)
-                (list
-                  name
-                  artdag/pipeline-op
-                  (artdag/entry-inputs (get n->e (get c :head)))
-                  {:stages (get c :stages)})
-                (get n->e name))))
-          (filter (fn (name) (not (artdag/member? name absorbed))) names))))))
-
-(define
-  artdag/fuse
-  (fn
-    (entries fusible?)
-    (artdag/build (artdag/fuse-entries entries fusible?))))
-
-; runner that replays a fused pipeline over its single input, delegating each
-; stage to a base runner; non-pipeline ops fall through unchanged.
-(define
-  artdag/pipeline-run
-  (fn
-    (base-runner)
-    (fn
-      (params inputs)
-      (reduce
-        (fn
-          (val stage)
-          (base-runner (get stage :op) (get stage :params) (list val)))
-        (first inputs)
-        (get params :stages)))))
-
-(define
-  artdag/fusing-runner
-  (fn
-    (base-runner)
-    (fn
-      (op params inputs)
-      (if
-        (= op artdag/pipeline-op)
-        ((artdag/pipeline-run base-runner) params inputs)
-        (base-runner op params inputs)))))
-
-; ---- full optimization pass ----
-; fuse the entry list, then drop everything not feeding the requested output
-; names. Output names survive fusion (sinks are never absorbed).
-(define
-  artdag/optimize
-  (fn
-    (entries outputs fusible?)
-    (let
-      ((fused (artdag/fuse entries fusible?)))
-      (artdag/dce fused (map (fn (nm) (artdag/dag-id fused nm)) outputs)))))

lib/artdag/plan.sx

@@ -1,100 +0,0 @@
-; lib/artdag/plan.sx — Phase 3: schedule a DAG (or its dirty subset) into
-; topological batches under a max-parallelism cap. A batch is a set of nodes
-; whose deps are all satisfied by earlier batches, so they run in parallel.
-; cap <= 0 means unlimited width. Depends on dag.sx and analyze.sx.
-
-; inputs of id that also lie inside the scheduled set (out-of-set deps are
-; treated as already satisfied — e.g. clean cache hits in an incremental plan).
-(define
-  artdag/-deps-in
-  (fn
-    (dag id sset)
-    (filter
-      (fn (in) (artdag/member? in sset))
-      (artdag/node-inputs (artdag/dag-get dag id)))))
-
-(define
-  artdag/-ready-in
-  (fn
-    (dag sset placed)
-    (filter
-      (fn
-        (id)
-        (and
-          (not (artdag/member? id placed))
-          (artdag/all-in? (artdag/-deps-in dag id sset) placed)))
-      (artdag/sort-strings sset))))
-
-(define
-  artdag/-batch-loop
-  (fn
-    (dag sset placed batches)
-    (if
-      (= (len placed) (len sset))
-      batches
-      (let
-        ((wave (artdag/-ready-in dag sset placed)))
-        (artdag/-batch-loop
-          dag
-          sset
-          (concat placed wave)
-          (concat batches (list wave)))))))
-
-; split a wave into consecutive chunks of at most n (sorted order preserved).
-(define
-  artdag/-chunk
-  (fn
-    (xs n)
-    (if
-      (<= (len xs) n)
-      (list xs)
-      (cons
-        (slice xs 0 n)
-        (artdag/-chunk (slice xs n (len xs)) n)))))
-
-(define
-  artdag/-cap-split
-  (fn
-    (batches cap)
-    (if
-      (<= cap 0)
-      batches
-      (reduce
-        (fn (acc b) (concat acc (artdag/-chunk b cap)))
-        (list)
-        batches))))
-
-; schedule an explicit set of node-ids into capped topological batches.
-(define
-  artdag/plan-subset
-  (fn
-    (dag node-ids cap)
-    (artdag/-cap-split (artdag/-batch-loop dag node-ids (list) (list)) cap)))
-
-; full plan over every node in the dag.
-(define
-  artdag/plan
-  (fn (dag cap) (artdag/plan-subset dag (keys (artdag/dag-nodes dag)) cap)))
-
-; incremental plan: schedule only the dirty closure of the changed nodes.
-(define
-  artdag/plan-dirty
-  (fn
-    (dag changed cap)
-    (artdag/plan-subset dag (artdag/dirty-closure dag changed) cap)))
-
-; ---- plan inspection ----
-
-(define artdag/plan-batches (fn (plan) (len plan)))
-
-(define
-  artdag/plan-width
-  (fn
-    (plan)
-    (reduce (fn (m b) (if (> (len b) m) (len b) m)) 0 plan)))
-
-(define
-  artdag/plan-flatten
-  (fn (plan) (reduce (fn (acc b) (concat acc b)) (list) plan)))
-
-(define artdag/plan-size (fn (plan) (len (artdag/plan-flatten plan))))

lib/artdag/scoreboard.json

@@ -1,17 +0,0 @@
-{
-  "suites": {
-    "dag": {"pass": 20, "fail": 0},
-    "analyze": {"pass": 16, "fail": 0},
-    "plan": {"pass": 18, "fail": 0},
-    "execute": {"pass": 15, "fail": 0},
-    "optimize": {"pass": 22, "fail": 0},
-    "fed": {"pass": 15, "fail": 0},
-    "cost": {"pass": 13, "fail": 0},
-    "serialize": {"pass": 13, "fail": 0},
-    "stats": {"pass": 12, "fail": 0},
-    "fault": {"pass": 14, "fail": 0}
-  },
-  "total_pass": 158,
-  "total_fail": 0,
-  "total": 158
-}

lib/artdag/scoreboard.md

@@ -1,17 +0,0 @@
-# artdag Conformance Scoreboard
-
-_Generated by `lib/artdag/conformance.sh`_
-
-| Suite | Pass | Fail | Total |
-|-------|-----:|-----:|------:|
-| dag | 20 | 0 | 20 |
-| analyze | 16 | 0 | 16 |
-| plan | 18 | 0 | 18 |
-| execute | 15 | 0 | 15 |
-| optimize | 22 | 0 | 22 |
-| fed | 15 | 0 | 15 |
-| cost | 13 | 0 | 13 |
-| serialize | 13 | 0 | 13 |
-| stats | 12 | 0 | 12 |
-| fault | 14 | 0 | 14 |
-| **Total** | **158** | **0** | **158** |

lib/artdag/serialize.sx

@@ -1,62 +0,0 @@
-; lib/artdag/serialize.sx — portable wire form for whole DAGs, so a peer can
-; receive and run a graph it did not author. The form is a topo-ordered list of
-; node records (id op inputs params commutative) — plain lists with keyword-keyed
-; param dicts, which survive write/read (unlike string-keyed node dicts). The id
-; is the content-id, so the form is self-verifying. Depends on dag.sx.
-
-(define
-  artdag/node->record
-  (fn
-    (dag id)
-    (let
-      ((n (artdag/dag-get dag id)))
-      (list
-        id
-        (artdag/node-op n)
-        (artdag/node-inputs n)
-        (artdag/node-params n)
-        (get n :commutative)))))
-
-; dag -> list of records, in topological order.
-(define
-  artdag/dag->wire
-  (fn
-    (dag)
-    (map (fn (id) (artdag/node->record dag id)) (artdag/dag-order dag))))
-
-; an empty input list reads back as nil; normalize it.
-(define
-  artdag/-rec-inputs
-  (fn (rec) (let ((i (nth rec 2))) (if (nil? i) (list) i))))
-
-(define artdag/-rec->node (fn (rec) {:inputs (artdag/-rec-inputs rec) :commutative (nth rec 4) :op (nth rec 1) :params (nth rec 3)}))
-
-; records -> dag. Local author names are not part of the wire form; the receiver
-; works by content-id. :names is left empty.
-(define
-  artdag/wire->dag
-  (fn
-    (records)
-    (reduce
-      (fn (dag rec) (let ((id (nth rec 0))) {:names (get dag :names) :order (concat (get dag :order) (list id)) :ok true :nodes (assoc (get dag :nodes) id (artdag/-rec->node rec))}))
-      {:names {} :order (list) :ok true :nodes {}}
-      records)))
-
-; integrity: each record's id must equal the content-id recomputed from its spec.
-(define
-  artdag/wire-verify
-  (fn
-    (records)
-    (every?
-      (fn
-        (rec)
-        (= (nth rec 0) (artdag/content-id (artdag/-rec->node rec))))
-      records)))
-
-; string transport.
-(define
-  artdag/dag->string
-  (fn (dag) (write-to-string (artdag/dag->wire dag))))
-(define
-  artdag/string->dag
-  (fn (s) (artdag/wire->dag (read (open-input-string s)))))

lib/artdag/stats.sx

@@ -1,51 +0,0 @@
-; lib/artdag/stats.sx — observability over an execution: cache hit ratio and the
-; compute work saved by memoization (weighted by the cost model). An exec is the
-; {:results :recomputed :hits} record returned by artdag/execute. Depends on
-; execute.sx (exec accessors) and cost.sx (artdag/-node-cost).
-
-(define
-  artdag/exec-total
-  (fn (exec) (+ (artdag/recompute-count exec) (artdag/hit-count exec))))
-
-; fraction of executed nodes served from cache (0 when nothing ran).
-(define
-  artdag/hit-ratio
-  (fn
-    (exec)
-    (let
-      ((n (artdag/exec-total exec)))
-      (if (= n 0) 0 (/ (artdag/hit-count exec) n)))))
-
-(define
-  artdag/-sum-cost
-  (fn
-    (dag cost-fn ids)
-    (reduce
-      (fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
-      0
-      ids)))
-
-; weighted compute work that actually ran this execution.
-(define
-  artdag/work-recomputed
-  (fn
-    (exec dag cost-fn)
-    (artdag/-sum-cost dag cost-fn (get exec :recomputed))))
-
-; weighted compute work avoided by cache hits.
-(define
-  artdag/work-saved
-  (fn (exec dag cost-fn) (artdag/-sum-cost dag cost-fn (get exec :hits))))
-
-; fraction of total weighted work that the cache saved (0 when no work at all).
-(define
-  artdag/savings-ratio
-  (fn
-    (exec dag cost-fn)
-    (let
-      ((saved (artdag/work-saved exec dag cost-fn))
-        (ran (artdag/work-recomputed exec dag cost-fn)))
-      (if (= (+ saved ran) 0) 0 (/ saved (+ saved ran))))))
-
-; compact summary dict for logging.
-(define artdag/exec-summary (fn (exec dag cost-fn) {:work-saved (artdag/work-saved exec dag cost-fn) :recomputed (artdag/recompute-count exec) :total (artdag/exec-total exec) :work-ran (artdag/work-recomputed exec dag cost-fn) :hits (artdag/hit-count exec)}))

lib/artdag/tests/analyze.sx

@@ -1,119 +0,0 @@
-; Phase 2 — Analyze on Datalog: deps/dependents/reachability + dirty closure.
-
-; diamond:  a -> b, a -> c, (b,c) -> d
-(define
-  an-D
-  (artdag/build
-    (list
-      (list "a" "load" (list) {})
-      (list "b" "f" (list "a") {})
-      (list "c" "g" (list "a") {})
-      (list "d" "add" (list "b" "c") {} true))))
-(define an-db (artdag/analyze an-D))
-(define an-a (artdag/dag-id an-D "a"))
-(define an-b (artdag/dag-id an-D "b"))
-(define an-c (artdag/dag-id an-D "c"))
-(define an-d (artdag/dag-id an-D "d"))
-
-; ---- direct deps / dependents ----
-
-(artdag-test
-  "deps-of: direct inputs"
-  (artdag/deps-of an-db an-d)
-  (artdag/sort-strings (list an-b an-c)))
-
-(artdag-test "deps-of: leaf has none" (artdag/deps-of an-db an-a) (list))
-
-(artdag-test
-  "dependents-of: direct consumers"
-  (artdag/dependents-of an-db an-a)
-  (artdag/sort-strings (list an-b an-c)))
-
-(artdag-test
-  "dependents-of: output has none"
-  (artdag/dependents-of an-db an-d)
-  (list))
-
-; ---- transitive reachability ----
-
-(artdag-test
-  "reachable-from: all downstream"
-  (artdag/reachable-from an-db an-a)
-  (artdag/sort-strings (list an-b an-c an-d)))
-
-(artdag-test
-  "reachable-from: mid node reaches output"
-  (artdag/reachable-from an-db an-b)
-  (list an-d))
-
-(artdag-test
-  "ancestors-of: all upstream"
-  (artdag/ancestors-of an-db an-d)
-  (artdag/sort-strings (list an-a an-b an-c)))
-
-(artdag-test
-  "ancestors-of: leaf has none"
-  (artdag/ancestors-of an-db an-a)
-  (list))
-
-; ---- deep chain ----
-
-(define
-  ch-D
-  (artdag/build
-    (list
-      (list "a" "load" (list) {})
-      (list "b" "f" (list "a") {})
-      (list "c" "f" (list "b") {})
-      (list "d" "f" (list "c") {}))))
-(define ch-db (artdag/analyze ch-D))
-
-(artdag-test
-  "deep chain: reachable-from leaf"
-  (artdag/reachable-from ch-db (artdag/dag-id ch-D "a"))
-  (artdag/sort-strings
-    (list
-      (artdag/dag-id ch-D "b")
-      (artdag/dag-id ch-D "c")
-      (artdag/dag-id ch-D "d"))))
-
-(artdag-test
-  "deep chain: ancestors of tip"
-  (artdag/ancestors-of ch-db (artdag/dag-id ch-D "d"))
-  (artdag/sort-strings
-    (list
-      (artdag/dag-id ch-D "a")
-      (artdag/dag-id ch-D "b")
-      (artdag/dag-id ch-D "c"))))
-
-; ---- dirty closure ----
-
-(artdag-test
-  "dirty closure: change leaf dirties all"
-  (artdag/dirty-closure an-D (list an-a))
-  (artdag/sort-strings (list an-a an-b an-c an-d)))
-
-(artdag-test
-  "dirty closure: change mid touches only downstream"
-  (artdag/dirty-closure an-D (list an-b))
-  (artdag/sort-strings (list an-b an-d)))
-
-(artdag-test
-  "dirty closure: unaffected stay clean (count)"
-  (len (artdag/dirty-closure an-D (list an-b)))
-  2)
-
-(artdag-test
-  "dirty closure: change output dirties only itself"
-  (artdag/dirty-closure an-D (list an-d))
-  (list an-d))
-
-(artdag-test
-  "dirty closure: multiple seeds union"
-  (artdag/dirty-closure an-D (list an-b an-c))
-  (artdag/sort-strings (list an-b an-c an-d)))
-
-(artdag-test
-  "dirty closure: empty seed set"
-  (artdag/dirty-closure an-D (list))
-  (list))

lib/artdag/tests/cost.sx

@@ -1,117 +0,0 @@
-; cost model: critical path, makespan under cap, total work, speedup.
-
-(define
-  cost-CHAIN
-  (artdag/build
-    (list
-      (list "a" "in" (list) {})
-      (list "b" "f" (list "a") {})
-      (list "c" "f" (list "b") {})
-      (list "d" "f" (list "c") {}))))
-
-(define
-  cost-DIA
-  (artdag/build
-    (list
-      (list "a" "in" (list) {})
-      (list "b" "f" (list "a") {})
-      (list "c" "g" (list "a") {})
-      (list "d" "add" (list "b" "c") {} true))))
-
-(define cost-W (artdag/op-cost {:f 2 :add 5}))
-
-; ---- unit cost ----
-
-(artdag-test
-  "critical path: chain is its length"
-  (artdag/critical-path cost-CHAIN artdag/const-cost)
-  4)
-
-(artdag-test
-  "critical path: diamond longest path"
-  (artdag/critical-path cost-DIA artdag/const-cost)
-  3)
-
-(artdag-test
-  "total work: unit cost equals node count"
-  (artdag/total-work cost-DIA artdag/const-cost)
-  4)
-
-(artdag-test
-  "single node critical path is its cost"
-  (artdag/critical-path
-    (artdag/build (list (list "a" "in" (list) {})))
-    artdag/const-cost)
-  1)
-
-; ---- makespan vs cap ----
-
-(artdag-test
-  "full plan makespan equals critical path"
-  (artdag/makespan
-    cost-DIA
-    (artdag/plan cost-DIA 0)
-    artdag/const-cost)
-  (artdag/critical-path cost-DIA artdag/const-cost))
-
-(artdag-test
-  "serial plan makespan equals total work"
-  (artdag/makespan
-    cost-DIA
-    (artdag/plan cost-DIA 1)
-    artdag/const-cost)
-  (artdag/total-work cost-DIA artdag/const-cost))
-
-(artdag-test
-  "capped makespan is never below the critical path"
-  (>=
-    (artdag/makespan
-      cost-DIA
-      (artdag/plan cost-DIA 1)
-      artdag/const-cost)
-    (artdag/critical-path cost-DIA artdag/const-cost))
-  true)
-
-; ---- weighted costs ----
-
-(artdag-test
-  "weighted critical path follows heavy ops"
-  (artdag/critical-path cost-DIA cost-W)
-  8)
-
-(artdag-test
-  "weighted total work sums all node costs"
-  (artdag/total-work cost-DIA cost-W)
-  9)
-
-(artdag-test
-  "op-cost defaults unknown ops to 1"
-  (artdag/total-work
-    (artdag/build (list (list "a" "in" (list) {})))
-    cost-W)
-  1)
-
-(artdag-test
-  "weighted full-plan makespan equals critical path"
-  (artdag/makespan cost-DIA (artdag/plan cost-DIA 0) cost-W)
-  (artdag/critical-path cost-DIA cost-W))
-
-; ---- speedup ----
-
-(artdag-test
-  "serial plan has no speedup"
-  (artdag/speedup
-    cost-DIA
-    (artdag/plan cost-DIA 1)
-    artdag/const-cost)
-  1)
-
-(artdag-test
-  "parallel plan beats serial"
-  (>
-    (artdag/speedup
-      cost-DIA
-      (artdag/plan cost-DIA 0)
-      artdag/const-cost)
-    1)
-  true)

lib/artdag/tests/dag.sx

@@ -1,182 +0,0 @@
-; Phase 1 — dag model + structural content addressing.
-
-; ---- content-id determinism ----
-
-(artdag-test
-  "same spec -> same id"
-  (equal?
-    (artdag/content-id (artdag/node "blur" (list "i1") {:r 3}))
-    (artdag/content-id (artdag/node "blur" (list "i1") {:r 3})))
-  true)
-
-(artdag-test
-  "op affects id"
-  (equal?
-    (artdag/content-id (artdag/node "blur" (list "i1") {}))
-    (artdag/content-id (artdag/node "sharpen" (list "i1") {})))
-  false)
-
-(artdag-test
-  "params affect id"
-  (equal?
-    (artdag/content-id (artdag/node "blur" (list "i1") {:r 3}))
-    (artdag/content-id (artdag/node "blur" (list "i1") {:r 5})))
-  false)
-
-(artdag-test
-  "inputs affect id"
-  (equal?
-    (artdag/content-id (artdag/node "add" (list "i1") {}))
-    (artdag/content-id (artdag/node "add" (list "i2") {})))
-  false)
-
-(artdag-test
-  "param key order does not affect id"
-  (equal?
-    (artdag/content-id (artdag/node "op" (list) {:a 1 :b 2}))
-    (artdag/content-id (artdag/node "op" (list) {:a 1 :b 2})))
-  true)
-
-; ---- commutativity ----
-
-(artdag-test
-  "commutative op: input order ignored"
-  (equal?
-    (artdag/content-id (artdag/cnode "add" (list "i1" "i2") {}))
-    (artdag/content-id (artdag/cnode "add" (list "i2" "i1") {})))
-  true)
-
-(artdag-test
-  "non-commutative op: input order matters"
-  (equal?
-    (artdag/content-id (artdag/node "sub" (list "i1" "i2") {}))
-    (artdag/content-id (artdag/node "sub" (list "i2" "i1") {})))
-  false)
-
-; ---- build: success ----
-
-(artdag-test
-  "build ok for valid dag"
-  (get
-    (artdag/build
-      (list
-        (list "a" "load" (list) {})
-        (list "b" "load" (list) {:s 1})
-        (list "c" "add" (list "a" "b") {})))
-    :ok)
-  true)
-
-(artdag-test
-  "node-count counts distinct nodes"
-  (artdag/node-count
-    (artdag/build
-      (list
-        (list "a" "load" (list) {})
-        (list "b" "load" (list) {:s 1})
-        (list "c" "add" (list "a" "b") {}))))
-  3)
-
-; ---- subgraph sharing ----
-
-(artdag-test
-  "identical leaves dedup to one node"
-  (artdag/node-count
-    (artdag/build
-      (list
-        (list "a" "load" (list) {:s 1})
-        (list "b" "load" (list) {:s 1})
-        (list "c" "add" (list "a" "b") {}))))
-  2)
-
-(artdag-test
-  "duplicate names map to same id"
-  (let
-    ((d (artdag/build (list (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 1})))))
-    (equal? (artdag/dag-id d "a") (artdag/dag-id d "b")))
-  true)
-
-(artdag-test
-  "identical subgraph shares id across dags"
-  (let
-    ((d1 (artdag/build (list (list "x" "load" (list) {:s 7}) (list "y" "neg" (list "x") {}))))
-      (d2
-        (artdag/build
-          (list
-            (list "p" "load" (list) {:s 7})
-            (list "q" "neg" (list "p") {})))))
-    (equal? (artdag/dag-id d1 "y") (artdag/dag-id d2 "q")))
-  true)
-
-; ---- validation ----
-
-(artdag-test
-  "cycle rejected"
-  (get
-    (artdag/build
-      (list
-        (list "a" "f" (list "b") {})
-        (list "b" "g" (list "a") {})))
-    :error)
-  "cycle")
-
-(artdag-test
-  "self-cycle rejected"
-  (get (artdag/build (list (list "a" "f" (list "a") {}))) :error)
-  "cycle")
-
-(artdag-test
-  "dangling input rejected"
-  (get
-    (artdag/build (list (list "a" "f" (list "ghost") {})))
-    :error)
-  "dangling")
-
-(artdag-test
-  "dangling refs reported"
-  (get
-    (artdag/build (list (list "a" "f" (list "ghost") {})))
-    :refs)
-  (list "ghost"))
-
-; ---- topological order ----
-
-(artdag-test
-  "topo order: deps before dependents"
-  (let
-    ((d (artdag/build (list (list "c" "add" (list "a" "b") {}) (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 2})))))
-    (artdag/dag-order d))
-  (let
-    ((d (artdag/build (list (list "c" "add" (list "a" "b") {}) (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 2})))))
-    (list (artdag/dag-id d "a") (artdag/dag-id d "b") (artdag/dag-id d "c"))))
-
-(artdag-test
-  "topo order: deep chain"
-  (let
-    ((d (artdag/build (list (list "d" "f" (list "c") {}) (list "c" "f" (list "b") {}) (list "b" "f" (list "a") {}) (list "a" "load" (list) {})))))
-    (artdag/dag-order d))
-  (let
-    ((d (artdag/build (list (list "d" "f" (list "c") {}) (list "c" "f" (list "b") {}) (list "b" "f" (list "a") {}) (list "a" "load" (list) {})))))
-    (list
-      (artdag/dag-id d "a")
-      (artdag/dag-id d "b")
-      (artdag/dag-id d "c")
-      (artdag/dag-id d "d"))))
-
-; ---- accessors ----
-
-(artdag-test
-  "dag-node-by-name returns node spec"
-  (artdag/node-op
-    (artdag/dag-node-by-name
-      (artdag/build (list (list "a" "load" (list) {})))
-      "a"))
-  "load")
-
-(artdag-test
-  "resolved inputs are content-ids"
-  (let
-    ((d (artdag/build (list (list "a" "load" (list) {}) (list "b" "neg" (list "a") {})))))
-    (artdag/node-inputs (artdag/dag-node-by-name d "b")))
-  (let
-    ((d (artdag/build (list (list "a" "load" (list) {}) (list "b" "neg" (list "a") {})))))
-    (list (artdag/dag-id d "a"))))

lib/artdag/tests/execute.sx

@@ -1,188 +0,0 @@
-; Phase 4 — Execute: effect interpreter + content-addressed memo + incremental.
-
-(define ex-RT (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
-
-; two-leaf diamond: p,q leaves; b=inc(p); c=inc(q); d=add(b,c)
-(define
-  ex-D1
-  (artdag/build
-    (list
-      (list "p" "in" (list) {:v 10})
-      (list "q" "in" (list) {:v 20})
-      (list "b" "inc" (list "p") {})
-      (list "c" "inc" (list "q") {})
-      (list "d" "add" (list "b" "c") {} true))))
-
-; same shape, leaf q changed (20 -> 21)
-(define
-  ex-D2
-  (artdag/build
-    (list
-      (list "p" "in" (list) {:v 10})
-      (list "q" "in" (list) {:v 21})
-      (list "b" "inc" (list "p") {})
-      (list "c" "inc" (list "q") {})
-      (list "d" "add" (list "b" "c") {} true))))
-
-; a different dag that shares the p->b subgraph with ex-D1, plus z=inc(b)
-(define
-  ex-D3
-  (artdag/build
-    (list
-      (list "p" "in" (list) {:v 10})
-      (list "b" "inc" (list "p") {})
-      (list "z" "inc" (list "b") {}))))
-
-; ---- full execution ----
-
-(artdag-test
-  "full run: result is correct"
-  (let
-    ((cache (persist/open)))
-    (artdag/result-of
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/dag-id ex-D1 "d")))
-  32)
-
-(artdag-test
-  "full run: cold cache recomputes every node"
-  (let
-    ((cache (persist/open)))
-    (artdag/recompute-count (artdag/run ex-D1 ex-RT cache)))
-  5)
-
-(artdag-test
-  "full run: cold cache has no hits"
-  (let
-    ((cache (persist/open)))
-    (artdag/hit-count (artdag/run ex-D1 ex-RT cache)))
-  0)
-
-; ---- memoization ----
-
-(artdag-test
-  "re-run unchanged: zero recomputes"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/recompute-count (artdag/run ex-D1 ex-RT cache))))
-  0)
-
-(artdag-test
-  "re-run unchanged: all cache hits"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/hit-count (artdag/run ex-D1 ex-RT cache))))
-  5)
-
-(artdag-test
-  "re-run unchanged: result preserved"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/result-of
-        (artdag/run ex-D1 ex-RT cache)
-        (artdag/dag-id ex-D1 "d"))))
-  32)
-
-; ---- incremental recompute (the keystone) ----
-
-(artdag-test
-  "leaf change recomputes only the dirty closure (count)"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/recompute-count (artdag/run ex-D2 ex-RT cache))))
-  3)
-
-(artdag-test
-  "leaf change: unchanged nodes are cache hits"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/hit-count (artdag/run ex-D2 ex-RT cache))))
-  2)
-
-(artdag-test
-  "leaf change: recomputed set is exactly q,c,d"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/recomputed (artdag/run ex-D2 ex-RT cache))))
-  (artdag/sort-strings
-    (list
-      (artdag/dag-id ex-D2 "q")
-      (artdag/dag-id ex-D2 "c")
-      (artdag/dag-id ex-D2 "d"))))
-
-(artdag-test
-  "leaf change: untouched sibling p is reused"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/member?
-        (artdag/dag-id ex-D2 "p")
-        (get (artdag/run ex-D2 ex-RT cache) :hits))))
-  true)
-
-(artdag-test
-  "leaf change: new result is correct"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/result-of
-        (artdag/run ex-D2 ex-RT cache)
-        (artdag/dag-id ex-D2 "d"))))
-  33)
-
-; ---- explicit dirty-only execution ----
-
-(artdag-test
-  "run-dirty: schedules only the changed closure"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/recompute-count
-        (artdag/run-dirty ex-D2 (list (artdag/dag-id ex-D2 "q")) ex-RT cache))))
-  3)
-
-; ---- cross-dag cache sharing (content addressing) ----
-
-(artdag-test
-  "shared subgraph hits cache across different dags"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/recompute-count (artdag/run ex-D3 ex-RT cache))))
-  1)
-
-(artdag-test
-  "shared subgraph: p and b reused across dags"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/hit-count (artdag/run ex-D3 ex-RT cache))))
-  2)
-
-(artdag-test
-  "shared subgraph: z still computes correctly"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run ex-D1 ex-RT cache)
-      (artdag/result-of
-        (artdag/run ex-D3 ex-RT cache)
-        (artdag/dag-id ex-D3 "z"))))
-  12)

lib/artdag/tests/fault.sx

@@ -1,144 +0,0 @@
-; fault-tolerant execution: failure confined to its closure, cache never poisoned.
-
-(define ft-BAD (artdag/op-table-runner {:boom (fn (p i) (artdag/fail "kaboom")) :in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
-
-(define ft-GOOD (artdag/op-table-runner {:boom (fn (p i) 99) :in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
-
-; p,q leaves; b=inc(p) (independent); c=boom(q); d=add(b,c)
-(define
-  ft-D
-  (artdag/build
-    (list
-      (list "p" "in" (list) {:v 10})
-      (list "q" "in" (list) {:v 20})
-      (list "b" "inc" (list "p") {})
-      (list "c" "boom" (list "q") {})
-      (list "d" "add" (list "b" "c") {} true))))
-
-; ---- markers ----
-
-(artdag-test
-  "fail constructor is detected"
-  (artdag/failed? (artdag/fail "x"))
-  true)
-
-(artdag-test
-  "plain values are not failures"
-  (artdag/failed? 42)
-  false)
-
-; ---- failure confinement ----
-
-(artdag-test
-  "failure count covers node and its dependents"
-  (let
-    ((cache (persist/open)))
-    (artdag/failure-count (artdag/run-safe ft-D ft-BAD cache)))
-  2)
-
-(artdag-test
-  "failed set is exactly c and d"
-  (let
-    ((cache (persist/open)))
-    (artdag/failed-nodes (artdag/run-safe ft-D ft-BAD cache)))
-  (artdag/sort-strings
-    (list (artdag/dag-id ft-D "c") (artdag/dag-id ft-D "d"))))
-
-(artdag-test
-  "independent branch still computes"
-  (let
-    ((cache (persist/open)))
-    (artdag/recompute-count (artdag/run-safe ft-D ft-BAD cache)))
-  3)
-
-(artdag-test
-  "independent node result is available"
-  (let
-    ((cache (persist/open)))
-    (artdag/result-of
-      (artdag/run-safe ft-D ft-BAD cache)
-      (artdag/dag-id ft-D "b")))
-  11)
-
-(artdag-test
-  "all-ok? is false when something failed"
-  (let
-    ((cache (persist/open)))
-    (artdag/all-ok? (artdag/run-safe ft-D ft-BAD cache)))
-  false)
-
-(artdag-test
-  "all-ok? is true on a clean run"
-  (let
-    ((cache (persist/open)))
-    (artdag/all-ok? (artdag/run-safe ft-D ft-GOOD cache)))
-  true)
-
-; ---- cache integrity ----
-
-(artdag-test
-  "good node is cached"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run-safe ft-D ft-BAD cache)
-      (persist/kv-has? cache (artdag/dag-id ft-D "b"))))
-  true)
-
-(artdag-test
-  "failed node is never cached"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run-safe ft-D ft-BAD cache)
-      (persist/kv-has? cache (artdag/dag-id ft-D "c"))))
-  false)
-
-; ---- retry after fix ----
-
-(artdag-test
-  "retry recomputes only the failed closure"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run-safe ft-D ft-BAD cache)
-      (artdag/recompute-count (artdag/run-safe ft-D ft-GOOD cache))))
-  2)
-
-(artdag-test
-  "retry reuses the good nodes from cache"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run-safe ft-D ft-BAD cache)
-      (artdag/hit-count (artdag/run-safe ft-D ft-GOOD cache))))
-  3)
-
-(artdag-test
-  "retry produces the correct result"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run-safe ft-D ft-BAD cache)
-      (artdag/result-of
-        (artdag/run-safe ft-D ft-GOOD cache)
-        (artdag/dag-id ft-D "d"))))
-  110)
-
-; ---- transitive cascade ----
-
-(artdag-test
-  "failure cascades through a deep chain"
-  (let
-    ((cache (persist/open)))
-    (artdag/failure-count
-      (artdag/run-safe
-        (artdag/build
-          (list
-            (list "a" "in" (list) {:v 1})
-            (list "b" "boom" (list "a") {})
-            (list "c" "inc" (list "b") {})
-            (list "d" "inc" (list "c") {})))
-        ft-BAD
-        cache)))
-  3)

lib/artdag/tests/fed.sx

@@ -1,157 +0,0 @@
-; Phase 6 — federation: shared content-addressed cache, trust gating, invalidation.
-
-(define fed-BASE (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
-
-(define
-  fed-D
-  (artdag/build
-    (list
-      (list "p" "in" (list) {:v 10})
-      (list "q" "in" (list) {:v 20})
-      (list "b" "inc" (list "p") {})
-      (list "c" "inc" (list "q") {})
-      (list "d" "add" (list "b" "c") {} true))))
-
-(define fed-trust-A (fn (p) (= p "A")))
-(define fed-trust-none (fn (p) false))
-
-; a warmed instance A and its export bundle (origin peer "A").
-(define fed-A (artdag/fed-open))
-(define fed-warm (artdag/fed-run fed-A fed-D fed-BASE))
-(define fed-bundle (artdag/fed-export fed-A "A"))
-
-; ---- export ----
-
-(artdag-test
-  "export: bundle covers every cached node"
-  (len fed-bundle)
-  5)
-
-; ---- remote cache hit ----
-
-(artdag-test
-  "trusted import enables remote cache hit (no recompute)"
-  (artdag/recompute-count
-    (artdag/fed-run
-      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
-      fed-D
-      fed-BASE))
-  0)
-
-(artdag-test
-  "trusted import: every node is a hit"
-  (artdag/hit-count
-    (artdag/fed-run
-      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
-      fed-D
-      fed-BASE))
-  5)
-
-(artdag-test
-  "remote hit yields correct result"
-  (artdag/result-of
-    (artdag/fed-run
-      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
-      fed-D
-      fed-BASE)
-    (artdag/dag-id fed-D "d"))
-  32)
-
-; ---- trust gating ----
-
-(artdag-test
-  "untrusted peer is rejected (recompute everything)"
-  (artdag/recompute-count
-    (artdag/fed-run
-      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-none)
-      fed-D
-      fed-BASE))
-  5)
-
-(artdag-test
-  "trust gating: untrusted records never enter the cache"
-  (let
-    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:foreign" :result 99} fed-bundle) fed-trust-A)))
-    (persist/kv-has? (artdag/fed-cache B) "node:foreign"))
-  false)
-
-(artdag-test
-  "trust gating: trusted records still admitted alongside rejected"
-  (let
-    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:foreign" :result 99} fed-bundle) fed-trust-A)))
-    (persist/kv-has? (artdag/fed-cache B) (artdag/dag-id fed-D "d")))
-  true)
-
-; ---- provenance ----
-
-(artdag-test
-  "provenance is recorded for imported results"
-  (get
-    (artdag/fed-prov
-      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A))
-    (artdag/dag-id fed-D "d"))
-  "A")
-
-(artdag-test
-  "locally computed results carry no provenance"
-  (len (keys (artdag/fed-prov fed-A)))
-  0)
-
-; ---- injected transport ----
-
-(artdag-test
-  "fed-pull imports via an injected fetch transport"
-  (artdag/recompute-count
-    (artdag/fed-run
-      (artdag/fed-pull
-        (artdag/fed-open)
-        (fn (peer) fed-bundle)
-        "A"
-        fed-trust-A)
-      fed-D
-      fed-BASE))
-  0)
-
-; ---- invalidation ----
-
-(artdag-test
-  "invalidation drops a peer's results (recompute again)"
-  (let
-    ((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
-    (artdag/recompute-count
-      (artdag/fed-run (artdag/fed-invalidate B "A") fed-D fed-BASE)))
-  5)
-
-(artdag-test
-  "invalidation: recomputed result still correct"
-  (let
-    ((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
-    (artdag/result-of
-      (artdag/fed-run (artdag/fed-invalidate B "A") fed-D fed-BASE)
-      (artdag/dag-id fed-D "d")))
-  32)
-
-(artdag-test
-  "invalidation: provenance map is cleared for that peer"
-  (let
-    ((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
-    (len (keys (artdag/fed-prov (artdag/fed-invalidate B "A")))))
-  0)
-
-(artdag-test
-  "invalidation is peer-scoped: other peers' results survive"
-  (let
-    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:fromC" :result 7} fed-bundle) (fn (p) true))))
-    (persist/kv-has?
-      (artdag/fed-cache (artdag/fed-invalidate B "A"))
-      "node:fromC"))
-  true)
-
-(artdag-test
-  "invalidation is peer-scoped: target peer's results removed"
-  (let
-    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:fromC" :result 7} fed-bundle) (fn (p) true))))
-    (persist/kv-has?
-      (artdag/fed-cache (artdag/fed-invalidate B "A"))
-      (artdag/dag-id fed-D "d")))
-  false)

lib/artdag/tests/optimize.sx

@@ -1,215 +0,0 @@
-; Phase 5 — optimization: DCE, CSE (content-id sharing), adjacent-op fusion.
-
-(define opt-BASE (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :sq (fn (params inputs) (* (first inputs) (first inputs))) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
-(define opt-RUN (artdag/fusing-runner opt-BASE))
-(define opt-inc? (fn (op) (= op "inc")))
-(define opt-incsq? (fn (op) (or (= op "inc") (= op "sq"))))
-
-; linear chain a(in) -> b -> c -> d, all inc
-(define
-  opt-chain
-  (list
-    (list "a" "in" (list) {:v 5})
-    (list "b" "inc" (list "a") {})
-    (list "c" "inc" (list "b") {})
-    (list "d" "inc" (list "c") {})))
-
-; ---- DCE ----
-
-(define
-  dce-entries
-  (list
-    (list "a" "in" (list) {:v 5})
-    (list "b" "inc" (list "a") {})
-    (list "c" "inc" (list "b") {})
-    (list "x" "sq" (list "a") {})))
-(define dce-G (artdag/build dce-entries))
-
-(artdag-test
-  "dce: removes dead node"
-  (artdag/node-count (artdag/dce dce-G (list (artdag/dag-id dce-G "c"))))
-  3)
-
-(artdag-test
-  "dce: keeps live closure intact"
-  (artdag/node-count (artdag/dce dce-G (list (artdag/dag-id dce-G "x"))))
-  2)
-
-(artdag-test
-  "dce: preserves surviving node ids"
-  (artdag/member?
-    (artdag/dag-id dce-G "c")
-    (keys
-      (artdag/dag-nodes (artdag/dce dce-G (list (artdag/dag-id dce-G "c"))))))
-  true)
-
-(artdag-test
-  "dce: output result unchanged after elimination"
-  (let
-    ((cache (persist/open)))
-    (artdag/result-of
-      (artdag/run
-        (artdag/dce dce-G (list (artdag/dag-id dce-G "c")))
-        opt-RUN
-        cache)
-      (artdag/dag-id dce-G "c")))
-  7)
-
-(artdag-test
-  "dce: nothing dead is a no-op on count"
-  (artdag/node-count
-    (artdag/dce
-      dce-G
-      (list (artdag/dag-id dce-G "c") (artdag/dag-id dce-G "x"))))
-  4)
-
-; ---- CSE (free from content addressing) ----
-
-(define
-  cse-entries
-  (list
-    (list "a" "in" (list) {:v 3})
-    (list "s1" "sq" (list "a") {})
-    (list "s2" "sq" (list "a") {})
-    (list "d" "add" (list "s1" "s2") {} true)))
-(define cse-C (artdag/cse cse-entries))
-
-(artdag-test
-  "cse: identical subexpressions collapse to one node"
-  (artdag/node-count cse-C)
-  3)
-
-(artdag-test
-  "cse: shared node computes once"
-  (let
-    ((cache (persist/open)))
-    (artdag/recompute-count (artdag/run cse-C opt-RUN cache)))
-  3)
-
-(artdag-test
-  "cse: s1 and s2 are the same id"
-  (equal? (artdag/dag-id cse-C "s1") (artdag/dag-id cse-C "s2"))
-  true)
-
-(artdag-test
-  "cse: result is correct"
-  (let
-    ((cache (persist/open)))
-    (artdag/result-of
-      (artdag/run cse-C opt-RUN cache)
-      (artdag/dag-id cse-C "d")))
-  18)
-
-; ---- fusion ----
-
-(artdag-test
-  "fusion: collapses a unary chain"
-  (artdag/node-count (artdag/fuse opt-chain opt-inc?))
-  2)
-
-(artdag-test
-  "fusion: unfused has all nodes"
-  (artdag/node-count (artdag/build opt-chain))
-  4)
-
-(artdag-test
-  "fusion: output-equivalent to unfused"
-  (let
-    ((c1 (persist/open)) (c2 (persist/open)))
-    (=
-      (artdag/result-of
-        (artdag/run (artdag/build opt-chain) opt-RUN c1)
-        (artdag/dag-id (artdag/build opt-chain) "d"))
-      (artdag/result-of
-        (artdag/run (artdag/fuse opt-chain opt-inc?) opt-RUN c2)
-        (artdag/dag-id (artdag/fuse opt-chain opt-inc?) "d"))))
-  true)
-
-(artdag-test
-  "fusion: leaf is never fused"
-  (artdag/node-op
-    (artdag/dag-node-by-name (artdag/fuse opt-chain opt-inc?) "a"))
-  "in")
-
-(artdag-test
-  "fusion: tail becomes a pipeline node"
-  (artdag/node-op
-    (artdag/dag-node-by-name (artdag/fuse opt-chain opt-inc?) "d"))
-  "artdag/pipeline")
-
-(artdag-test
-  "fusion: mixed fusible set fuses across op kinds"
-  (artdag/node-count
-    (artdag/fuse
-      (list
-        (list "a" "in" (list) {:v 2})
-        (list "b" "inc" (list "a") {})
-        (list "c" "sq" (list "b") {})
-        (list "d" "inc" (list "c") {}))
-      opt-incsq?))
-  2)
-
-(artdag-test
-  "fusion: mixed chain replays correctly"
-  (let
-    ((cache (persist/open)))
-    (let
-      ((f (artdag/fuse (list (list "a" "in" (list) {:v 2}) (list "b" "inc" (list "a") {}) (list "c" "sq" (list "b") {}) (list "d" "inc" (list "c") {})) opt-incsq?)))
-      (artdag/result-of (artdag/run f opt-RUN cache) (artdag/dag-id f "d"))))
-  10)
-
-(artdag-test
-  "fusion: fanout node is not fused"
-  (artdag/node-count
-    (artdag/fuse
-      (list
-        (list "a" "in" (list) {:v 1})
-        (list "b" "inc" (list "a") {})
-        (list "c" "inc" (list "b") {})
-        (list "e" "sq" (list "b") {}))
-      opt-inc?))
-  4)
-
-(artdag-test
-  "fusion: empty fusible set leaves dag unchanged"
-  (artdag/node-count (artdag/fuse opt-chain (fn (op) false)))
-  4)
-
-; ---- full optimization pass (fuse + dce) ----
-
-(define
-  optp-entries
-  (list
-    (list "a" "in" (list) {:v 5})
-    (list "b" "inc" (list "a") {})
-    (list "c" "inc" (list "b") {})
-    (list "x" "sq" (list "a") {})))
-
-(artdag-test
-  "optimize: fuses chain and drops dead node"
-  (artdag/node-count (artdag/optimize optp-entries (list "c") opt-inc?))
-  2)
-
-(artdag-test
-  "optimize: leaves dead node when it is an output"
-  (artdag/node-count (artdag/optimize optp-entries (list "c" "x") opt-inc?))
-  3)
-
-(artdag-test
-  "optimize: result equals the unoptimized dag"
-  (let
-    ((c1 (persist/open)) (c2 (persist/open)))
-    (let
-      ((o (artdag/optimize optp-entries (list "c") opt-inc?)))
-      (=
-        (artdag/result-of (artdag/run o opt-RUN c1) (artdag/dag-id o "c"))
-        (artdag/result-of
-          (artdag/run (artdag/build optp-entries) opt-RUN c2)
-          (artdag/dag-id (artdag/build optp-entries) "c")))))
-  true)
-
-(artdag-test
-  "optimize: no fusible ops still drops dead nodes"
-  (artdag/node-count
-    (artdag/optimize optp-entries (list "c") (fn (op) false)))
-  3)

lib/artdag/tests/plan.sx

@@ -1,122 +0,0 @@
-; Phase 3 — Plan: topological batches under a parallelism cap, incremental plan.
-
-; diamond:  a -> b, a -> c, (b,c) -> d
-(define
-  pl-D
-  (artdag/build
-    (list
-      (list "a" "load" (list) {})
-      (list "b" "f" (list "a") {})
-      (list "c" "g" (list "a") {})
-      (list "d" "add" (list "b" "c") {} true))))
-(define pl-a (artdag/dag-id pl-D "a"))
-(define pl-b (artdag/dag-id pl-D "b"))
-(define pl-c (artdag/dag-id pl-D "c"))
-(define pl-d (artdag/dag-id pl-D "d"))
-
-; wide:  a -> b, c, e, f  (four independent dependents)
-(define
-  pl-W
-  (artdag/build
-    (list
-      (list "a" "load" (list) {})
-      (list "b" "f" (list "a") {})
-      (list "c" "g" (list "a") {})
-      (list "e" "h" (list "a") {})
-      (list "f" "k" (list "a") {}))))
-
-; ---- full plan, unlimited width ----
-
-(artdag-test
-  "full plan: batch count"
-  (artdag/plan-batches (artdag/plan pl-D 0))
-  3)
-
-(artdag-test
-  "full plan: schedules every node"
-  (artdag/plan-size (artdag/plan pl-D 0))
-  4)
-
-(artdag-test
-  "full plan: first batch is the leaf"
-  (first (artdag/plan pl-D 0))
-  (list pl-a))
-
-(artdag-test
-  "full plan: middle batch runs b,c in parallel"
-  (first (rest (artdag/plan pl-D 0)))
-  (artdag/sort-strings (list pl-b pl-c)))
-
-(artdag-test
-  "full plan: last batch is the sink"
-  (first (rest (rest (artdag/plan pl-D 0))))
-  (list pl-d))
-
-(artdag-test
-  "full plan: max width is 2"
-  (artdag/plan-width (artdag/plan pl-D 0))
-  2)
-
-; ---- parallelism cap ----
-
-(artdag-test
-  "cap 1: width never exceeds 1"
-  (artdag/plan-width (artdag/plan pl-D 1))
-  1)
-
-(artdag-test
-  "cap 1: serializes into one node per batch"
-  (artdag/plan-batches (artdag/plan pl-D 1))
-  4)
-
-(artdag-test
-  "cap larger than widest wave is a no-op"
-  (artdag/plan pl-D 10)
-  (artdag/plan pl-D 0))
-
-(artdag-test
-  "wide cap 2: width capped at 2"
-  (artdag/plan-width (artdag/plan pl-W 2))
-  2)
-
-(artdag-test
-  "wide cap 2: leaf wave then two capped sub-batches"
-  (artdag/plan-batches (artdag/plan pl-W 2))
-  3)
-
-(artdag-test
-  "wide cap 2: still schedules all five nodes"
-  (artdag/plan-size (artdag/plan pl-W 2))
-  5)
-
-(artdag-test
-  "wide unlimited: single wave of four after leaf"
-  (artdag/plan-width (artdag/plan pl-W 0))
-  4)
-
-; ---- incremental (dirty-only) plan ----
-
-(artdag-test
-  "dirty plan: schedules only the dirty closure"
-  (artdag/plan-size (artdag/plan-dirty pl-D (list pl-b) 0))
-  2)
-
-(artdag-test
-  "dirty plan: b then d"
-  (artdag/plan-dirty pl-D (list pl-b) 0)
-  (list (list pl-b) (list pl-d)))
-
-(artdag-test
-  "dirty plan: clean deps treated as satisfied"
-  (first (artdag/plan-dirty pl-D (list pl-b) 0))
-  (list pl-b))
-
-(artdag-test
-  "dirty plan: leaf change replans whole graph"
-  (artdag/plan-size (artdag/plan-dirty pl-D (list pl-a) 0))
-  4)
-
-(artdag-test
-  "dirty plan: sink change is a single batch"
-  (artdag/plan-dirty pl-D (list pl-d) 0)
-  (list (list pl-d)))

lib/artdag/tests/serialize.sx

@@ -1,115 +0,0 @@
-; portable wire form: dag <-> records <-> string, with content-id integrity.
-
-(define ser-RT (artdag/op-table-runner {:in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
-
-(define
-  ser-D
-  (artdag/build
-    (list
-      (list "a" "in" (list) {:v 10})
-      (list "b" "inc" (list "a") {})
-      (list "c" "add" (list "a" "b") {} true))))
-
-(define ser-cid (artdag/dag-id ser-D "c"))
-
-; ---- wire form ----
-
-(artdag-test
-  "wire has one record per node"
-  (len (artdag/dag->wire ser-D))
-  3)
-
-(artdag-test
-  "wire records follow topological order"
-  (map (fn (rec) (nth rec 0)) (artdag/dag->wire ser-D))
-  (artdag/dag-order ser-D))
-
-(artdag-test
-  "wire record carries the content-id"
-  (nth (nth (artdag/dag->wire ser-D) 0) 0)
-  (artdag/dag-id ser-D "a"))
-
-; ---- reconstruction ----
-
-(artdag-test
-  "wire->dag restores node count"
-  (artdag/node-count (artdag/wire->dag (artdag/dag->wire ser-D)))
-  3)
-
-(artdag-test
-  "wire->dag restores order"
-  (artdag/dag-order (artdag/wire->dag (artdag/dag->wire ser-D)))
-  (artdag/dag-order ser-D))
-
-(artdag-test
-  "reconstructed leaf inputs normalize to empty list"
-  (artdag/node-inputs
-    (artdag/dag-get
-      (artdag/wire->dag (artdag/dag->wire ser-D))
-      (artdag/dag-id ser-D "a")))
-  (list))
-
-(artdag-test
-  "reconstructed node preserves inputs"
-  (artdag/node-inputs
-    (artdag/dag-get (artdag/wire->dag (artdag/dag->wire ser-D)) ser-cid))
-  (artdag/node-inputs (artdag/dag-get ser-D ser-cid)))
-
-(artdag-test
-  "reconstructed node id matches recomputed content-id"
-  (artdag/content-id
-    (artdag/dag-get (artdag/wire->dag (artdag/dag->wire ser-D)) ser-cid))
-  ser-cid)
-
-; ---- execution equivalence ----
-
-(artdag-test
-  "reconstructed dag executes to same result"
-  (let
-    ((c1 (persist/open)) (c2 (persist/open)))
-    (=
-      (artdag/result-of (artdag/run ser-D ser-RT c1) ser-cid)
-      (artdag/result-of
-        (artdag/run (artdag/wire->dag (artdag/dag->wire ser-D)) ser-RT c2)
-        ser-cid)))
-  true)
-
-(artdag-test
-  "string round-trip executes to same result"
-  (let
-    ((cache (persist/open)))
-    (artdag/result-of
-      (artdag/run
-        (artdag/string->dag (artdag/dag->string ser-D))
-        ser-RT
-        cache)
-      ser-cid))
-  21)
-
-; ---- integrity ----
-
-(artdag-test
-  "wire-verify accepts a genuine wire form"
-  (artdag/wire-verify (artdag/dag->wire ser-D))
-  true)
-
-(artdag-test
-  "wire-verify rejects a tampered id"
-  (artdag/wire-verify
-    (list (list "node:bogus" "in" (list) {:v 1} false)))
-  false)
-
-(artdag-test
-  "wire-verify rejects mutated params under a stale id"
-  (artdag/wire-verify
-    (map
-      (fn
-        (rec)
-        (list
-          (nth rec 0)
-          (nth rec 1)
-          (nth rec 2)
-          {:v 999}
-          (nth rec 4)))
-      (artdag/dag->wire ser-D)))
-  false)

lib/artdag/tests/stats.sx

@@ -1,150 +0,0 @@
-; execution stats: hit ratio + memoized work saved (cost-weighted).
-
-(define st-RT (artdag/op-table-runner {:in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
-
-(define
-  st-D
-  (artdag/build
-    (list
-      (list "p" "in" (list) {:v 10})
-      (list "q" "in" (list) {:v 20})
-      (list "b" "inc" (list "p") {})
-      (list "c" "inc" (list "q") {})
-      (list "d" "add" (list "b" "c") {} true))))
-
-; same shape, leaf q changed -> dirty closure {q,c,d}
-(define
-  st-D2
-  (artdag/build
-    (list
-      (list "p" "in" (list) {:v 10})
-      (list "q" "in" (list) {:v 21})
-      (list "b" "inc" (list "p") {})
-      (list "c" "inc" (list "q") {})
-      (list "d" "add" (list "b" "c") {} true))))
-
-(define st-W (artdag/op-cost {:add 5 :inc 2}))
-
-; ---- cold run ----
-
-(artdag-test
-  "cold run: hit ratio is zero"
-  (let
-    ((cache (persist/open)))
-    (artdag/hit-ratio (artdag/run st-D st-RT cache)))
-  0)
-
-(artdag-test
-  "cold run: nothing saved"
-  (let
-    ((cache (persist/open)))
-    (artdag/work-saved (artdag/run st-D st-RT cache) st-D artdag/const-cost))
-  0)
-
-(artdag-test
-  "cold run: all work runs"
-  (let
-    ((cache (persist/open)))
-    (artdag/work-recomputed
-      (artdag/run st-D st-RT cache)
-      st-D
-      artdag/const-cost))
-  5)
-
-(artdag-test
-  "cold run: weighted work ran"
-  (let
-    ((cache (persist/open)))
-    (artdag/work-recomputed (artdag/run st-D st-RT cache) st-D st-W))
-  11)
-
-; ---- warm rerun ----
-
-(artdag-test
-  "warm rerun: hit ratio is one"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run st-D st-RT cache)
-      (artdag/hit-ratio (artdag/run st-D st-RT cache))))
-  1)
-
-(artdag-test
-  "warm rerun: savings ratio is one"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run st-D st-RT cache)
-      (artdag/savings-ratio
-        (artdag/run st-D st-RT cache)
-        st-D
-        artdag/const-cost)))
-  1)
-
-(artdag-test
-  "warm rerun: all weighted work saved"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run st-D st-RT cache)
-      (artdag/work-saved (artdag/run st-D st-RT cache) st-D st-W)))
-  11)
-
-; ---- partial (incremental) ----
-
-(artdag-test
-  "incremental: total is every node"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run st-D st-RT cache)
-      (artdag/exec-total (artdag/run st-D2 st-RT cache))))
-  5)
-
-(artdag-test
-  "incremental: saved work counts unchanged nodes"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run st-D st-RT cache)
-      (artdag/work-saved
-        (artdag/run st-D2 st-RT cache)
-        st-D2
-        artdag/const-cost)))
-  2)
-
-(artdag-test
-  "incremental: ran work counts dirty closure"
-  (let
-    ((cache (persist/open)))
-    (begin
-      (artdag/run st-D st-RT cache)
-      (artdag/work-recomputed
-        (artdag/run st-D2 st-RT cache)
-        st-D2
-        artdag/const-cost)))
-  3)
-
-(artdag-test
-  "summary reports recompute count"
-  (let
-    ((cache (persist/open)))
-    (get
-      (artdag/exec-summary
-        (artdag/run st-D st-RT cache)
-        st-D
-        artdag/const-cost)
-      :recomputed))
-  5)
-
-(artdag-test
-  "summary reports total"
-  (let
-    ((cache (persist/open)))
-    (get
-      (artdag/exec-summary
-        (artdag/run st-D st-RT cache)
-        st-D
-        artdag/const-cost)
-      :total))
-  5)

lib/commerce/api.sx

@@ -1,56 +0,0 @@
-;; lib/commerce/api.sx — public commerce surface.
-;;
-;; A session bundles a pricing context with a cart: {:ctx CTX :cart CART}.
-;; All operations are pure and return a new session. The total and the
-;; per-line breakdown are deterministic functions of (ctx, cart).
-;;
-;; commerce-checkout is a Phase-3 stub — the order lifecycle is a durable
-;; flow that suspends at the SumUp payment boundary.
-
-(define commerce-session (fn (ctx) {:cart empty-cart :ctx ctx}))
-
-(define commerce-ctx (fn (sess) (get sess :ctx)))
-(define commerce-cart (fn (sess) (get sess :cart)))
-(define commerce-lines (fn (sess) (cart-lines (get sess :cart))))
-(define commerce-count (fn (sess) (cart-count (get sess :cart))))
-
-(define
-  commerce-add
-  (fn
-    (sess sku variant qty)
-    (assoc sess :cart (cart-add (get sess :cart) sku variant qty))))
-
-(define
-  commerce-remove
-  (fn
-    (sess sku variant)
-    (assoc sess :cart (cart-remove (get sess :cart) sku variant))))
-
-(define
-  commerce-set-qty
-  (fn
-    (sess sku variant qty)
-    (assoc sess :cart (cart-set-qty (get sess :cart) sku variant qty))))
-
-;; True when the sku exists in the session's catalog snapshot.
-(define
-  commerce-can-add?
-  (fn (sess sku) (catalog-has? (ctx-catalog (get sess :ctx)) sku)))
-
-(define
-  commerce-total
-  (fn (sess) (cart-total (get sess :ctx) (get sess :cart))))
-
-;; Per-line audit breakdown — the "which line contributed what" view.
-(define
-  line-detail
-  (fn (ctx line) (let ((cat (ctx-catalog ctx))) {:sku (line-sku line) :unit (line-unit-price cat (line-sku line) (line-variant line)) :qty (line-qty line) :variant (line-variant line) :extended (line-extended cat line) :tax (line-tax ctx line)})))
-
-(define
-  commerce-explain
-  (fn
-    (sess)
-    (map (fn (l) (line-detail (get sess :ctx) l)) (get sess :cart))))
-
-;; Phase 3 — order lifecycle flow (reserve -> pay -> fulfil) lands here.
-(define commerce-checkout (fn (sess) {:note "order lifecycle flow lands in Phase 3" :phase 3 :status :not-implemented}))

lib/commerce/attribution.sx

@@ -1,100 +0,0 @@
-;; lib/commerce/attribution.sx — line-level discount attribution.
-;;
-;; The briefing's marquee backward query: "which line item triggered this
-;; discount?". promo.sx computes discount amounts at the class/order level;
-;; this layer answers the *scope* question relationally and in both directions:
-;;   forward  — which lines does code C touch?   (lines-for-code)
-;;   backward — which codes touch this line?     (codes-for-line)
-;; Both are the same relation promo-toucheso run with different vars bound.
-;;
-;; A :fixed promo is order-level (touches no single line); query those with
-;; order-level-codes. Only promos that actually apply (amount > 0) touch lines.
-
-;; Lines whose sku is in product-class `cls`.
-(define
-  class-lines
-  (fn
-    (ctx cart cls)
-    (filter
-      (fn (l) (= (catalog-class (ctx-catalog ctx) (line-sku l)) cls))
-      cart)))
-
-;; The lines a promo applies to (its scope). :fixed is order-level → no lines.
-(define
-  promo-lines
-  (fn
-    (ctx cart p)
-    (let
-      ((k (promo-kind p)))
-      (cond
-        ((= k :percent) (class-lines ctx cart (nth p 2)))
-        ((= k :member)
-          (if
-            (= (get ctx :customer) :member)
-            (class-lines ctx cart (nth p 2))
-            (list)))
-        ((= k :bundle)
-          (filter (fn (l) (= (line-sku l) (nth p 2))) cart))
-        (:else (list))))))
-
-;; Relation: promo `code` touches `line`. Only applying promos (amount > 0)
-;; touch anything, so an inapplicable promo contributes no pairs.
-(define
-  promo-toucheso
-  (fn
-    (ctx cart ruleset code line)
-    (fresh
-      (p)
-      (membero p ruleset)
-      (project
-        (p)
-        (if
-          (> (promo-amount ctx cart p) 0)
-          (mk-conj
-            (== code (promo-code p))
-            (membero line (promo-lines ctx cart p)))
-          fail)))))
-
-;; --- query helpers ---
-
-(define
-  lines-for-code
-  (fn
-    (ctx cart ruleset code)
-    (run* line (promo-toucheso ctx cart ruleset code line))))
-
-(define
-  codes-for-line
-  (fn
-    (ctx cart ruleset line)
-    (run* code (promo-toucheso ctx cart ruleset code line))))
-
-(define
-  line-touched-by?
-  (fn
-    (ctx cart ruleset code line)
-    (not
-      (empty?
-        (run
-          1
-          c
-          (mk-conj (promo-toucheso ctx cart ruleset code line) (== c true)))))))
-
-;; Applying order-level (:fixed) promos — discounts with no single line.
-(define
-  order-level-codes
-  (fn
-    (ctx cart ruleset)
-    (run*
-      code
-      (fresh
-        (p)
-        (membero p ruleset)
-        (project
-          (p)
-          (if
-            (and
-              (> (promo-amount ctx cart p) 0)
-              (= (promo-kind p) :fixed))
-            (== code (promo-code p))
-            fail))))))

lib/commerce/cart.sx

@@ -1,86 +0,0 @@
-;; lib/commerce/cart.sx — cart as an ordered list of line items.
-;;
-;; A cart is a native list of lines; a line is (list sku variant qty).
-;; All operations are pure: they return a new cart, never mutate. Line
-;; order is insertion order (stable) so totals are reproducible.
-;;
-;; cart-lineo is the relational view — because a line *is* a (sku variant qty)
-;; tuple, membero queries the cart directly, forward or backward.
-
-(define empty-cart (list))
-
-(define make-line (fn (sku variant qty) (list sku variant qty)))
-(define line-sku (fn (l) (nth l 0)))
-(define line-variant (fn (l) (nth l 1)))
-(define line-qty (fn (l) (nth l 2)))
-
-(define
-  same-line?
-  (fn
-    (l sku variant)
-    (and (= (line-sku l) sku) (= (line-variant l) variant))))
-
-(define
-  cart-qty
-  (fn
-    (cart sku variant)
-    (let
-      ((m (filter (fn (l) (same-line? l sku variant)) cart)))
-      (if (empty? m) 0 (line-qty (first m))))))
-
-(define
-  cart-remove
-  (fn
-    (cart sku variant)
-    (filter (fn (l) (not (same-line? l sku variant))) cart)))
-
-;; Add qty units; merges into an existing (sku,variant) line in place,
-;; otherwise appends a new line at the end.
-(define
-  cart-add
-  (fn
-    (cart sku variant qty)
-    (let
-      ((existing (cart-qty cart sku variant)))
-      (if
-        (= existing 0)
-        (append cart (list (make-line sku variant qty)))
-        (map
-          (fn
-            (l)
-            (if
-              (same-line? l sku variant)
-              (make-line sku variant (+ existing qty))
-              l))
-          cart)))))
-
-;; Set the absolute quantity; qty <= 0 removes the line.
-(define
-  cart-set-qty
-  (fn
-    (cart sku variant qty)
-    (if
-      (<= qty 0)
-      (cart-remove cart sku variant)
-      (if
-        (= (cart-qty cart sku variant) 0)
-        (append cart (list (make-line sku variant qty)))
-        (map
-          (fn
-            (l)
-            (if (same-line? l sku variant) (make-line sku variant qty) l))
-          cart)))))
-
-(define cart-empty? (fn (cart) (empty? cart)))
-(define cart-lines (fn (cart) cart))
-(define cart-skus (fn (cart) (map line-sku cart)))
-
-;; Total number of units across all lines.
-(define
-  cart-count
-  (fn (cart) (reduce (fn (acc l) (+ acc (line-qty l))) 0 cart)))
-
-;; Relational view of cart lines.
-(define
-  cart-lineo
-  (fn (cart sku variant qty) (membero (list sku variant qty) cart)))

lib/commerce/catalog.sx

@@ -1,83 +0,0 @@
-;; lib/commerce/catalog.sx — catalog snapshot + relational accessors.
-;;
-;; A catalog snapshot is an immutable dict:
-;;   {:products (list (list sku price class) ...)
-;;    :variants (list (list sku variant delta) ...)
-;;    :stock    (list (list sku variant qty) ...)}
-;;
-;; Money is integer minor units (pence/cents). class is a keyword product
-;; class consumed later by tax and promotion relations. delta is a signed
-;; price adjustment for a variant; qty is on-hand stock for (sku,variant).
-;;
-;; Accessor relations take the snapshot as the first argument and are fully
-;; multidirectional: (producto cat "widget" p c) binds p,c forward;
-;; (producto cat s 1000 c) enumerates every sku priced 1000 backward.
-
-(define empty-catalog {:products (list) :stock (list) :variants (list)})
-
-(define make-catalog (fn (products variants stock) {:products products :stock stock :variants variants}))
-
-(define cat-products (fn (cat) (get cat :products)))
-(define cat-variants (fn (cat) (get cat :variants)))
-(define cat-stock (fn (cat) (get cat :stock)))
-
-;; --- core fact relations ---
-
-(define
-  producto
-  (fn
-    (cat sku price class)
-    (membero (list sku price class) (get cat :products))))
-
-(define
-  varianto
-  (fn
-    (cat sku variant delta)
-    (membero (list sku variant delta) (get cat :variants))))
-
-(define
-  stocko
-  (fn
-    (cat sku variant qty)
-    (membero (list sku variant qty) (get cat :stock))))
-
-;; --- derived relations ---
-
-(define
-  priceo
-  (fn (cat sku price) (fresh (c) (producto cat sku price c))))
-
-(define
-  classo
-  (fn (cat sku class) (fresh (p) (producto cat sku p class))))
-
-;; Effective unit price of a (sku,variant): base + variant delta.
-(define
-  unit-priceo
-  (fn
-    (cat sku variant price)
-    (fresh
-      (base delta)
-      (priceo cat sku base)
-      (varianto cat sku variant delta)
-      (pluso-i base delta price))))
-
-;; --- deterministic lookups (first solution under fixed fact order) ---
-
-(define
-  catalog-price
-  (fn
-    (cat sku)
-    (let
-      ((rs (run 1 p (priceo cat sku p))))
-      (if (empty? rs) nil (first rs)))))
-
-(define
-  catalog-class
-  (fn
-    (cat sku)
-    (let
-      ((rs (run 1 c (classo cat sku c))))
-      (if (empty? rs) nil (first rs)))))
-
-(define catalog-has? (fn (cat sku) (not (nil? (catalog-price cat sku)))))

lib/commerce/conformance.sh

@@ -1,153 +0,0 @@
-#!/usr/bin/env bash
-# lib/commerce/conformance.sh — run commerce test suites in one sx_server
-# process per suite, emit scoreboard.json + scoreboard.md.
-#
-# commerce-on-sx builds pricing/promotion as miniKanren relations, so every
-# suite loads the miniKanren stack first, then the commerce modules.
-
-set -uo pipefail
-cd "$(git rev-parse --show-toplevel)"
-
-SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
-if [ ! -x "$SX_SERVER" ]; then
-  SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
-fi
-if [ ! -x "$SX_SERVER" ]; then
-  echo "ERROR: sx_server.exe not found." >&2
-  exit 1
-fi
-
-SUITES=(catalog cart price api promo stack quote ledger order recon federation attribution payment window nettax stock refund integration)
-
-OUT_JSON="lib/commerce/scoreboard.json"
-OUT_MD="lib/commerce/scoreboard.md"
-
-run_suite() {
-  local suite=$1
-  local file="lib/commerce/tests/${suite}.sx"
-  local TMP
-  TMP=$(mktemp)
-  cat > "$TMP" << EPOCHS
-(epoch 1)
-(load "spec/stdlib.sx")
-(load "lib/r7rs.sx")
-(load "lib/guest/match.sx")
-(load "lib/minikanren/unify.sx")
-(load "lib/minikanren/stream.sx")
-(load "lib/minikanren/goals.sx")
-(load "lib/minikanren/fresh.sx")
-(load "lib/minikanren/conde.sx")
-(load "lib/minikanren/run.sx")
-(load "lib/minikanren/relations.sx")
-(load "lib/minikanren/project.sx")
-(load "lib/minikanren/intarith.sx")
-(load "lib/minikanren/matche.sx")
-(load "lib/minikanren/defrel.sx")
-(load "lib/persist/event.sx")
-(load "lib/persist/backend.sx")
-(load "lib/persist/log.sx")
-(load "lib/persist/kv.sx")
-(load "lib/persist/idempotency.sx")
-(load "lib/guest/lex.sx")
-(load "lib/guest/reflective/env.sx")
-(load "lib/guest/reflective/quoting.sx")
-(load "lib/scheme/parser.sx")
-(load "lib/scheme/eval.sx")
-(load "lib/scheme/runtime.sx")
-(load "lib/flow/spec.sx")
-(load "lib/flow/store.sx")
-(load "lib/flow/remote.sx")
-(load "lib/flow/host.sx")
-(load "lib/flow/api.sx")
-(load "lib/commerce/catalog.sx")
-(load "lib/commerce/cart.sx")
-(load "lib/commerce/price.sx")
-(load "lib/commerce/api.sx")
-(load "lib/commerce/promo.sx")
-(load "lib/commerce/stack.sx")
-(load "lib/commerce/quote.sx")
-(load "lib/commerce/window.sx")
-(load "lib/commerce/nettax.sx")
-(load "lib/commerce/stock.sx")
-(load "lib/commerce/ledger.sx")
-(load "lib/commerce/order.sx")
-(load "lib/commerce/refund.sx")
-(load "lib/commerce/payment.sx")
-(load "lib/commerce/recon.sx")
-(load "lib/commerce/federation.sx")
-(load "lib/commerce/attribution.sx")
-(epoch 2)
-(eval "(define ct-pass 0)")
-(eval "(define ct-fail 0)")
-(eval "(define ct-fails (list))")
-(eval "(define commerce-test (fn (name got expected) (if (= got expected) (set! ct-pass (+ ct-pass 1)) (begin (set! ct-fail (+ ct-fail 1)) (append! ct-fails name)))))")
-(epoch 3)
-(load "${file}")
-(epoch 4)
-(eval "(list ct-pass ct-fail)")
-(eval "ct-fails")
-EPOCHS
-
-  local OUTPUT
-  OUTPUT=$(timeout 560 "$SX_SERVER" < "$TMP" 2>/dev/null)
-  rm -f "$TMP"
-
-  # The (list ct-pass ct-fail) result follows its (ok-len 2 N) ack line.
-  local LINE
-  LINE=$(echo "$OUTPUT" | grep -oE '^\([0-9]+ [0-9]+\)$' | tail -1)
-  local P F
-  P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\1/')
-  F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\2/')
-  P=${P:-0}
-  F=${F:-0}
-  echo "${P} ${F}"
-}
-
-declare -A SUITE_PASS
-declare -A SUITE_FAIL
-TOTAL_PASS=0
-TOTAL_FAIL=0
-
-echo "Running commerce conformance suite..." >&2
-for s in "${SUITES[@]}"; do
-  read -r p f < <(run_suite "$s")
-  SUITE_PASS[$s]=$p
-  SUITE_FAIL[$s]=$f
-  TOTAL_PASS=$((TOTAL_PASS + p))
-  TOTAL_FAIL=$((TOTAL_FAIL + f))
-  printf "  %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
-done
-
-{
-  printf '{\n'
-  printf '  "suites": {\n'
-  first=1
-  for s in "${SUITES[@]}"; do
-    if [ $first -eq 0 ]; then printf ',\n'; fi
-    printf '    "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
-    first=0
-  done
-  printf '\n  },\n'
-  printf '  "total_pass": %d,\n' "$TOTAL_PASS"
-  printf '  "total_fail": %d,\n' "$TOTAL_FAIL"
-  printf '  "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
-  printf '}\n'
-} > "$OUT_JSON"
-
-{
-  printf '# commerce Conformance Scoreboard\n\n'
-  printf '_Generated by `lib/commerce/conformance.sh`_\n\n'
-  printf '| Suite | Pass | Fail | Total |\n'
-  printf '|-------|-----:|-----:|------:|\n'
-  for s in "${SUITES[@]}"; do
-    p=${SUITE_PASS[$s]}
-    f=${SUITE_FAIL[$s]}
-    printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
-  done
-  printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
-} > "$OUT_MD"
-
-echo "Wrote $OUT_JSON and $OUT_MD" >&2
-echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
-
-[ "$TOTAL_FAIL" -eq 0 ]

lib/commerce/federation.sx

@@ -1,86 +0,0 @@
-;; lib/commerce/federation.sx — cross-instance catalog (federated marketplace).
-;;
-;; STUB: instances are registered in-process; there is no real network or
-;; ActivityPub transport here (that lives in the federation service). The point
-;; is the relational model: a federated catalog is just the UNION of each
-;; instance's product facts, tagged with origin, so the same miniKanren
-;; relations answer cross-instance questions — "which instances sell this sku?",
-;; "which is cheapest?" — as backward queries, no new query engine.
-
-(define federation-stub? true)
-
-(define make-federation (fn (instance cat) {:instances (list (list instance cat))}))
-
-(define
-  federation-add
-  (fn
-    (fed instance cat)
-    (assoc
-      fed
-      :instances (append (get fed :instances) (list (list instance cat))))))
-
-(define federation-instances (fn (fed) (map first (get fed :instances))))
-
-;; Flatten to (instance sku price class) origin-tagged tuples.
-(define
-  fed-products
-  (fn
-    (fed)
-    (reduce
-      (fn
-        (acc pair)
-        (let
-          ((instance (first pair)) (cat (nth pair 1)))
-          (append
-            acc
-            (map (fn (p) (cons instance p)) (get cat :products)))))
-      (list)
-      (get fed :instances))))
-
-;; --- relations over the federated catalog (multidirectional) ---
-
-(define
-  fed-producto
-  (fn
-    (fed instance sku price class)
-    (membero (list instance sku price class) (fed-products fed))))
-
-(define
-  fed-priceo
-  (fn
-    (fed instance sku price)
-    (fresh (c) (fed-producto fed instance sku price c))))
-
-;; --- query helpers ---
-
-;; Which instances carry a sku? (backward query)
-(define
-  instances-with-sku
-  (fn (fed sku) (run* inst (fresh (p c) (fed-producto fed inst sku p c)))))
-
-;; All (price instance) offers for a sku, in federation order.
-(define
-  sku-offers
-  (fn
-    (fed sku)
-    (run*
-      pair
-      (fresh
-        (inst p c)
-        (fed-producto fed inst sku p c)
-        (== pair (list p inst))))))
-
-;; Cheapest (price instance) for a sku — the deterministic selection layer.
-(define
-  cheapest-offer
-  (fn
-    (fed sku)
-    (let
-      ((offers (sku-offers fed sku)))
-      (if
-        (empty? offers)
-        nil
-        (reduce
-          (fn (best x) (if (< (first x) (first best)) x best))
-          (first offers)
-          offers)))))

lib/commerce/ledger.sx

@@ -1,176 +0,0 @@
-;; lib/commerce/ledger.sx — the order ledger as a persist event stream.
-;;
-;; Each order is an append-only stream "order/<id>" in a persist backend.
-;; Order state is never stored directly — it is a projection (fold) over the
-;; events, so the ledger is the single source of truth and replays identically.
-;;
-;; Lifecycle events:
-;;   :created   quote snapshot {:subtotal :discount :tax :total :codes ...}
-;;   :reserved  stock reserved
-;;   :paid      {:amount :ref}  — recorded idempotently on the payment ref
-;;   :fulfilled order shipped/delivered
-;;   :cancelled / :refunded
-;;
-;; Idempotency: the SumUp webhook can fire twice for one payment. order-pay
-;; uses persist/append-once keyed by the payment ref, so a replayed webhook
-;; yields the SAME :paid event without double-recording. Reconciliation then
-;; detects genuine mismatches (paid != ordered) across the whole ledger.
-
-(define order-stream (fn (order-id) (str "order/" order-id)))
-
-;; --- writes ---
-
-(define
-  order-create
-  (fn
-    (b order-id at quote)
-    (persist/append b (order-stream order-id) :created at quote)))
-
-(define
-  order-reserve
-  (fn
-    (b order-id at data)
-    (persist/append b (order-stream order-id) :reserved at data)))
-
-;; Idempotent on payment ref — a replayed webhook does not double-record.
-(define
-  order-pay
-  (fn
-    (b order-id ref at amount)
-    (persist/append-once b (order-stream order-id) ref :paid at {:amount amount :ref ref})))
-
-(define
-  order-fulfil
-  (fn
-    (b order-id at data)
-    (persist/append b (order-stream order-id) :fulfilled at data)))
-
-(define
-  order-cancel
-  (fn
-    (b order-id at reason)
-    (persist/append b (order-stream order-id) :cancelled at {:reason reason})))
-
-(define
-  order-refund
-  (fn
-    (b order-id ref at amount)
-    (persist/append-once
-      b
-      (order-stream order-id)
-      (str "refund/" ref)
-      :refunded at
-      {:amount amount :ref ref})))
-
-;; --- reads ---
-
-(define
-  order-events
-  (fn (b order-id) (persist/read b (order-stream order-id))))
-
-;; --- projections over an event list ---
-
-(define
-  order-status-of
-  (fn
-    (events)
-    (reduce
-      (fn
-        (st e)
-        (let
-          ((t (persist/event-type e)))
-          (cond
-            ((= t :created) :pending)
-            ((= t :reserved) :reserved)
-            ((= t :paid) :paid)
-            ((= t :fulfilled) :fulfilled)
-            ((= t :cancelled) :cancelled)
-            ((= t :refunded) :refunded)
-            (:else st))))
-      :new events)))
-
-(define
-  order-total-of
-  (fn
-    (events)
-    (let
-      ((created (filter (fn (e) (= (persist/event-type e) :created)) events)))
-      (if
-        (empty? created)
-        0
-        (get (persist/event-data (first created)) :total)))))
-
-(define
-  order-paid-amount-of
-  (fn
-    (events)
-    (reduce
-      (fn
-        (acc e)
-        (if
-          (= (persist/event-type e) :paid)
-          (+ acc (get (persist/event-data e) :amount))
-          acc))
-      0
-      events)))
-
-(define
-  order-refunded-amount-of
-  (fn
-    (events)
-    (reduce
-      (fn
-        (acc e)
-        (if
-          (= (persist/event-type e) :refunded)
-          (+ acc (get (persist/event-data e) :amount))
-          acc))
-      0
-      events)))
-
-;; Net settled = paid - refunded. Reconciliation compares this to the order
-;; total, but only once a payment exists.
-(define
-  order-recon-of
-  (fn
-    (events)
-    (let
-      ((net (- (order-paid-amount-of events) (order-refunded-amount-of events)))
-        (total (order-total-of events))
-        (has-paid (some (fn (e) (= (persist/event-type e) :paid)) events)))
-      (cond
-        ((not has-paid) :unpaid)
-        ((= net total) :ok)
-        ((< net total) :underpaid)
-        (:else :overpaid)))))
-
-;; --- backend-level helpers ---
-
-(define
-  order-status
-  (fn (b order-id) (order-status-of (order-events b order-id))))
-(define
-  order-total
-  (fn (b order-id) (order-total-of (order-events b order-id))))
-(define
-  order-paid
-  (fn (b order-id) (order-paid-amount-of (order-events b order-id))))
-(define
-  order-recon
-  (fn (b order-id) (order-recon-of (order-events b order-id))))
-
-(define order-ids (fn (b) (persist/backend-streams b)))
-
-;; Streams whose net payment does not match the order total (true mismatches,
-;; excluding orders that are simply not yet paid).
-(define
-  ledger-mismatches
-  (fn
-    (b)
-    (filter
-      (fn
-        (s)
-        (let
-          ((r (order-recon-of (persist/read b s))))
-          (or (= r :underpaid) (= r :overpaid))))
-      (persist/backend-streams b))))

lib/commerce/nettax.sx

@@ -1,80 +0,0 @@
-;; lib/commerce/nettax.sx — discount-aware tax (alternative policy).
-;;
-;; price.sx / quote.sx tax the GROSS per-line amounts (discount reduces payable
-;; but not the tax base). This module is the alternative explicit policy: tax the
-;; NET (post-discount) base. The basket-level discount is allocated across lines
-;; in proportion to each line's extended price, with a deterministic
-;; largest-remainder pass so per-line shares sum EXACTLY to the discount; tax is
-;; then charged on each line's net at its class rate.
-;;
-;; Both policies are reproducible from (ctx, cart, ruleset, exclusions); pick the
-;; one the jurisdiction requires. cart-quote-net mirrors cart-quote's shape.
-
-(define ct-sum (fn (xs) (reduce (fn (a x) (+ a x)) 0 xs)))
-
-;; Add 1 to the first `rem` elements (deterministic remainder distribution).
-(define
-  ct-add-rem
-  (fn
-    (xs rem)
-    (cond
-      ((empty? xs) (list))
-      ((> rem 0)
-        (cons
-          (+ (first xs) 1)
-          (ct-add-rem (rest xs) (- rem 1))))
-      (:else xs))))
-
-;; Per-line discount allocation (parallel to cart), summing exactly to
-;; total-discount, proportional to line-extended share.
-(define
-  allocate-discount
-  (fn
-    (cat cart total-discount)
-    (let
-      ((sub (cart-subtotal cat cart)))
-      (if
-        (= sub 0)
-        (map (fn (l) 0) cart)
-        (let
-          ((floors (map (fn (l) (quotient (* total-discount (line-extended cat l)) sub)) cart)))
-          (ct-add-rem floors (- total-discount (ct-sum floors))))))))
-
-;; Tax on one line's net (extended - allocated discount), clamped at 0.
-(define
-  net-line-tax
-  (fn
-    (ctx line alloc)
-    (let
-      ((cat (ctx-catalog ctx)))
-      (let
-        ((net (- (line-extended cat line) alloc)))
-        (apply-bps
-          (if (< net 0) 0 net)
-          (rate-bps
-            (get ctx :tax-rules)
-            (get ctx :jurisdiction)
-            (catalog-class cat (line-sku line))
-            (get ctx :customer)))))))
-
-(define
-  net-tax
-  (fn
-    (ctx cart allocations)
-    (ct-sum
-      (map (fn (line alloc) (net-line-tax ctx line alloc)) cart allocations))))
-
-;; Discount-aware quote: tax computed on the net (post-discount) base.
-(define
-  cart-quote-net
-  (fn
-    (ctx cart ruleset exclusions)
-    (let
-      ((cat (ctx-catalog ctx)))
-      (let
-        ((sub (cart-subtotal cat cart))
-          (disc (best-promo-discount ctx cart ruleset exclusions))
-          (codes (best-promo-codes ctx cart ruleset exclusions)))
-        (let
-          ((tax (net-tax ctx cart (allocate-discount cat cart disc))))
-          {:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax})))))

lib/commerce/order.sx

@@ -1,119 +0,0 @@
-;; lib/commerce/order.sx — order lifecycle as a durable flow-on-sx flow.
-;;
-;; The lifecycle (reserve -> await payment -> fulfil) is a Scheme flow running
-;; in the flow-on-sx guest (lib/flow). The flow is PURE ORCHESTRATION: it
-;; carries only the order-id and enforces step ordering + the suspension at the
-;; payment IO boundary. All IO/state lives in SX: the SX driver here services
-;; each flow request by appending to the persist ledger (ledger.sx).
-;;
-;;   reserve  -> SX appends :reserved, resumes  (synchronous host effect)
-;;   payment  -> flow stays SUSPENDED until the SumUp webhook resumes it
-;;   fulfil   -> SX appends :fulfilled, resumes (synchronous host effect)
-;;
-;; Durability: the flow's replay log is plain data (flow-store-export), so a
-;; suspended order survives a process restart — order-flow-restart! simulates
-;; that entirely Scheme-side. Idempotency: order-settle! only resumes a flow
-;; still waiting on payment, so a replayed webhook is a no-op at the flow level,
-;; and order-pay is idempotent at the ledger level.
-
-;; The flow definition (Scheme source). oid is in scope throughout the begin.
-(define
-  order-flow-src
-  "(defflow order-lifecycle (lambda (oid) (begin (request (quote reserve) oid) (request (quote payment) oid) (request (quote fulfil) oid))))")
-
-;; Build a flow env with the order flow registered. Never returns the env from
-;; an eval boundary (the env is large/cyclic — serializing it hangs).
-(define
-  order-make-env
-  (fn
-    ()
-    (let
-      ((env (flow-make-env)))
-      (begin (flow-run-in env order-flow-src) env))))
-
-;; --- thin Scheme bridge (string-interpolated flow ops) ---
-
-(define
-  order-flow-start
-  (fn
-    (env oid)
-    (flow-run-in env (str "(flow/start order-lifecycle \"" oid "\")"))))
-
-(define
-  order-flow-resume
-  (fn
-    (env id sym)
-    (flow-run-in env (str "(flow/resume " id " (quote " sym "))"))))
-
-(define
-  order-flow-status
-  (fn (env id) (flow-run-in env (str "(flow/status " id ")"))))
-(define
-  order-flow-result
-  (fn (env id) (flow-run-in env (str "(flow/result " id ")"))))
-
-;; The request kind the flow with this id is waiting on, or nil if it is not
-;; suspended on a host request (done / cancelled / unknown).
-(define
-  order-flow-waiting
-  (fn
-    (env id)
-    (let
-      ((reqs (flow-run-in env "(flow-host-requests)")))
-      (let
-        ((mine (filter (fn (r) (= (first r) id)) reqs)))
-        (if (empty? mine) nil (nth (first mine) 1))))))
-
-;; Id out of a (flow-suspended id tag) start/resume result.
-(define order-susp-id (fn (susp) (nth susp 1)))
-
-;; --- high-level lifecycle (flow + ledger composed) ---
-
-;; Create the order, start the flow, service the reserve step, and leave the
-;; flow suspended at payment. Returns the flow id (needed to settle later).
-(define
-  order-begin!
-  (fn
-    (env b oid at quote)
-    (begin
-      (order-create b oid at quote)
-      (let
-        ((id (order-susp-id (order-flow-start env oid))))
-        (begin
-          (order-reserve b oid (+ at 1) {})
-          (order-flow-resume env id :reserved)
-          id)))))
-
-;; Settle a payment: record it, resume the flow past payment, service fulfil.
-;; Idempotent — only acts when the flow is still waiting on payment, so a
-;; replayed webhook returns :already-settled without double-charging.
-(define
-  order-settle!
-  (fn
-    (env b id oid ref at amount)
-    (if
-      (= (order-flow-waiting env id) "payment")
-      (begin
-        (order-pay b oid ref at amount)
-        (order-flow-resume env id :paid)
-        (order-fulfil b oid (+ at 1) {})
-        (order-flow-resume env id :fulfilled)
-        :settled)
-      :already-settled)))
-
-;; Simulate a process restart: export the flow store, reset the runtime, reload
-;; the flow definition, reimport the store. Done entirely Scheme-side so the
-;; (large) store is never marshalled across the boundary. The persist ledger is
-;; a separate store and is unaffected. Suspended flows resume afterwards.
-(define
-  order-flow-restart!
-  (fn
-    (env)
-    (flow-run-in
-      env
-      (str
-        "(begin (define _saved (flow-store-export)) "
-        flow-reset-src
-        " "
-        order-flow-src
-        " (flow-store-import! _saved) #t)"))))

lib/commerce/payment.sx

@@ -1,41 +0,0 @@
-;; lib/commerce/payment.sx — provider-neutral payment-request envelope.
-;;
-;; The order flow (order.sx) suspends on `(request 'payment oid)` — it carries
-;; ONLY the order-id and calls no provider. This layer materialises, at the IO
-;; edge, the envelope a provider adapter needs to initiate payment:
-;;
-;;   {:order oid :amount <ledger total> :currency C :return-url U}
-;;
-;; amount comes from the ledger (the :created quote total); currency + return-url
-;; are host/provider config (legitimately host-supplied). The engine stays
-;; vendor-agnostic: SumUp/Stripe/etc. adapters consume this envelope, and
-;; order-settle!(ref, amount) is the vendor-neutral resume seam. No provider
-;; SDK, HTTP, or webhook parsing lives here — that is the orders service's job.
-
-(define payment-request (fn (b oid currency return-url) {:order oid :amount (order-total b oid) :return-url return-url :currency currency}))
-
-(define payment-request-order (fn (pr) (get pr :order)))
-(define payment-request-amount (fn (pr) (get pr :amount)))
-(define payment-request-currency (fn (pr) (get pr :currency)))
-(define payment-request-return-url (fn (pr) (get pr :return-url)))
-
-;; A Scheme string carried as a flow payload round-trips back to SX wrapped as
-;; {:scm-string "..."}; unwrap it to the bare order-id.
-(define
-  scm->string
-  (fn
-    (v)
-    (if (and (dict? v) (has-key? v :scm-string)) (get v :scm-string) v)))
-
-;; Host poller seam: every order currently suspended awaiting payment, each with
-;; its envelope. A provider adapter iterates these, initiates payment, and later
-;; calls order-settle! when the webhook arrives. Needs the flow env.
-(define
-  pending-payments
-  (fn
-    (env b currency return-url)
-    (let
-      ((reqs (flow-run-in env "(flow-host-requests)")))
-      (map
-        (fn (r) {:id (first r) :request (payment-request b (scm->string (nth r 2)) currency return-url)})
-        (filter (fn (r) (= (nth r 1) "payment")) reqs)))))

lib/commerce/price.sx

@@ -1,110 +0,0 @@
-;; lib/commerce/price.sx — deterministic subtotal + jurisdiction-relational tax.
-;;
-;; A pricing context bundles the inputs that make a total reproducible:
-;;   {:catalog CAT :tax-rules RULES :jurisdiction J :customer C}
-;; Same context + same cart => identical total, every run.
-;;
-;; Tax is NOT a hardcoded VAT rate. Rules are facts indexed by
-;;   (jurisdiction, product-class, customer-class) -> rate-bps
-;; where rate-bps is an integer in basis points (2000 = 20%). taxo queries
-;; them multidirectionally. Money stays in integer minor units; rounding is
-;; half-up per line via integer arithmetic only — never floats.
-
-(define
-  make-pricing-context
-  (fn (catalog tax-rules jurisdiction customer) {:customer customer :jurisdiction jurisdiction :catalog catalog :tax-rules tax-rules}))
-
-(define ctx-catalog (fn (ctx) (get ctx :catalog)))
-
-;; --- unit + line pricing ---
-
-;; Variant delta, defaulting to 0 when the (sku,variant) has no variant fact.
-(define
-  variant-delta
-  (fn
-    (cat sku variant)
-    (let
-      ((rs (run 1 d (varianto cat sku variant d))))
-      (if (empty? rs) 0 (first rs)))))
-
-;; Effective unit price = base price + variant delta. nil if sku unknown.
-(define
-  line-unit-price
-  (fn
-    (cat sku variant)
-    (let
-      ((base (catalog-price cat sku)))
-      (if (nil? base) nil (+ base (variant-delta cat sku variant))))))
-
-;; Extended (line) price = unit price * quantity.
-(define
-  line-extended
-  (fn
-    (cat line)
-    (*
-      (line-unit-price cat (line-sku line) (line-variant line))
-      (line-qty line))))
-
-(define
-  cart-subtotal
-  (fn
-    (cat cart)
-    (reduce (fn (acc l) (+ acc (line-extended cat l))) 0 cart)))
-
-;; --- tax (jurisdiction-relational) ---
-
-;; rules: (list (list jurisdiction class customer bps) ...)
-(define
-  taxo
-  (fn
-    (rules juris class cust bps)
-    (membero (list juris class cust bps) rules)))
-
-;; Deterministic rate lookup; 0 when no rule matches.
-(define
-  rate-bps
-  (fn
-    (rules juris class cust)
-    (let
-      ((rs (run 1 b (taxo rules juris class cust b))))
-      (if (empty? rs) 0 (first rs)))))
-
-;; Apply a basis-point rate to an integer amount, rounding half up.
-(define
-  apply-bps
-  (fn (amount bps) (quotient (+ (* amount bps) 5000) 10000)))
-
-(define
-  line-tax
-  (fn
-    (ctx line)
-    (let
-      ((cat (ctx-catalog ctx)))
-      (let
-        ((class (catalog-class cat (line-sku line))))
-        (apply-bps
-          (line-extended cat line)
-          (rate-bps
-            (get ctx :tax-rules)
-            (get ctx :jurisdiction)
-            class
-            (get ctx :customer)))))))
-
-(define
-  cart-tax
-  (fn
-    (ctx cart)
-    (reduce (fn (acc l) (+ acc (line-tax ctx l))) 0 cart)))
-
-;; --- total ---
-
-;; Returns {:subtotal :discounts :tax :total}. discounts is 0 until Phase 2.
-(define
-  cart-total
-  (fn
-    (ctx cart)
-    (let
-      ((cat (ctx-catalog ctx)))
-      (let
-        ((sub (cart-subtotal cat cart)) (tax (cart-tax ctx cart)))
-        {:subtotal sub :discounts 0 :total (+ sub tax) :tax tax}))))

lib/commerce/promo.sx

@@ -1,153 +0,0 @@
-;; lib/commerce/promo.sx — promotions as relations over the cart + catalog.
-;;
-;; A promo is a tagged tuple; the second field is always its code:
-;;   (:percent code class pct-bps)   pct-bps off every line of product-class
-;;   (:fixed   code threshold amount) amount off when subtotal >= threshold
-;;   (:bundle  code sku n)            every nth unit of sku is free
-;;   (:member  code class pct-bps)    like :percent, members only
-;;
-;; A ruleset is a list of promo tuples. The discount a promo yields on a
-;; given cart is a pure integer computation (minor units); the *enumeration*
-;; of which promos apply is relational, so promo-applieso runs forward
-;; ("which codes apply and for how much?") and backward ("which code yields
-;; this discount?"). Stacking precedence is a separate layer (stack.sx).
-
-(define promo-kind (fn (p) (nth p 0)))
-(define promo-code (fn (p) (nth p 1)))
-
-;; Extended price of all lines whose sku is in product-class `class`.
-(define
-  class-extended
-  (fn
-    (ctx cart class)
-    (let
-      ((cat (ctx-catalog ctx)))
-      (reduce
-        (fn
-          (acc l)
-          (if
-            (= (catalog-class cat (line-sku l)) class)
-            (+ acc (line-extended cat l))
-            acc))
-        0
-        cart))))
-
-(define
-  sku-qty
-  (fn
-    (cart sku)
-    (reduce
-      (fn (acc l) (if (= (line-sku l) sku) (+ acc (line-qty l)) acc))
-      0
-      cart)))
-
-;; --- per-type discount amounts (pure, integer minor units) ---
-
-(define
-  percent-amount
-  (fn
-    (ctx cart p)
-    (apply-bps
-      (class-extended ctx cart (nth p 2))
-      (nth p 3))))
-
-(define
-  fixed-amount
-  (fn
-    (ctx cart p)
-    (let
-      ((sub (cart-subtotal (ctx-catalog ctx) cart)))
-      (if
-        (>= sub (nth p 2))
-        (min (nth p 3) sub)
-        0))))
-
-(define
-  bundle-amount
-  (fn
-    (ctx cart p)
-    (let
-      ((sku (nth p 2)) (n (nth p 3)))
-      (let
-        ((free (quotient (sku-qty cart sku) n)))
-        (* free (catalog-price (ctx-catalog ctx) sku))))))
-
-(define
-  member-amount
-  (fn
-    (ctx cart p)
-    (if
-      (= (get ctx :customer) :member)
-      (apply-bps
-        (class-extended ctx cart (nth p 2))
-        (nth p 3))
-      0)))
-
-;; Discount this promo yields on this cart (0 if it does not apply).
-(define
-  promo-amount
-  (fn
-    (ctx cart p)
-    (let
-      ((k (promo-kind p)))
-      (cond
-        ((= k :percent) (percent-amount ctx cart p))
-        ((= k :fixed) (fixed-amount ctx cart p))
-        ((= k :bundle) (bundle-amount ctx cart p))
-        ((= k :member) (member-amount ctx cart p))
-        (:else 0)))))
-
-;; --- relational enumeration ---
-
-;; (code, amount) for every promo in the ruleset (amount may be 0).
-(define
-  promo-discounto
-  (fn
-    (ctx cart ruleset code amount)
-    (fresh
-      (p)
-      (membero p ruleset)
-      (project
-        (p)
-        (== code (promo-code p))
-        (== amount (promo-amount ctx cart p))))))
-
-;; (code, amount) restricted to promos that actually apply (amount > 0).
-(define
-  promo-applieso
-  (fn
-    (ctx cart ruleset code amount)
-    (fresh
-      (p)
-      (membero p ruleset)
-      (project
-        (p)
-        (if
-          (> (promo-amount ctx cart p) 0)
-          (mk-conj
-            (== code (promo-code p))
-            (== amount (promo-amount ctx cart p)))
-          fail)))))
-
-;; --- deterministic helpers ---
-
-;; List of (list code amount) for applicable promos, in ruleset order.
-(define
-  applicable-promos
-  (fn
-    (ctx cart ruleset)
-    (run*
-      pair
-      (fresh
-        (code amount)
-        (promo-applieso ctx cart ruleset code amount)
-        (== pair (list code amount))))))
-
-;; Discount for one code (0 if absent / inapplicable).
-(define
-  promo-amount-for
-  (fn
-    (ctx cart ruleset code)
-    (let
-      ((rs (run 1 a (promo-applieso ctx cart ruleset code a))))
-      (if (empty? rs) 0 (first rs)))))

lib/commerce/quote.sx

@@ -1,36 +0,0 @@
-;; lib/commerce/quote.sx — the final priced quote: price + promo + stacking.
-;;
-;; A quote is the deterministic composition of the pricing pipeline for a
-;; (context, cart, ruleset, exclusions) tuple:
-;;   {:subtotal S :discount D :tax T :total (S - D + T) :codes (...)}
-;;
-;; Tax policy (explicit, for the determinism contract): tax is computed on the
-;; GROSS per-line amounts (pre-discount), via price.sx cart-tax. The best
-;; promo stacking reduces the payable total but not the tax base. Same inputs
-;; always yield the same quote — this is the value the order flow carries.
-
-(define
-  cart-quote
-  (fn
-    (ctx cart ruleset exclusions)
-    (let
-      ((cat (ctx-catalog ctx)))
-      (let
-        ((sub (cart-subtotal cat cart))
-          (disc (best-promo-discount ctx cart ruleset exclusions))
-          (tax (cart-tax ctx cart))
-          (codes (best-promo-codes ctx cart ruleset exclusions)))
-        {:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax}))))
-
-(define quote-subtotal (fn (q) (get q :subtotal)))
-(define quote-discount (fn (q) (get q :discount)))
-(define quote-tax (fn (q) (get q :tax)))
-(define quote-total (fn (q) (get q :total)))
-(define quote-codes (fn (q) (get q :codes)))
-
-;; Session-level convenience (a session is {:ctx :cart}).
-(define
-  session-quote
-  (fn
-    (sess ruleset exclusions)
-    (cart-quote (get sess :ctx) (get sess :cart) ruleset exclusions)))

lib/commerce/recon.sx

@@ -1,100 +0,0 @@
-;; lib/commerce/recon.sx — reconciliation as relational queries over the ledger.
-;;
-;; The ledger (ledger.sx) is the source of truth; reconciliation projects it
-;; into per-order summary tuples and then asks miniKanren questions about them.
-;; "Which orders are overpaid?" / "which order settled to net N?" are backward
-;; queries (run*) over the same relation, not separate code paths.
-;;
-;; A summary tuple is positional:
-;;   (order-stream total paid refunded net status)
-;; net = paid - refunded; status = :unpaid|:ok|:underpaid|:overpaid.
-
-(define
-  order-summary
-  (fn
-    (b stream)
-    (let
-      ((events (persist/read b stream)))
-      (let
-        ((total (order-total-of events))
-          (paid (order-paid-amount-of events))
-          (refunded (order-refunded-amount-of events)))
-        (list
-          stream
-          total
-          paid
-          refunded
-          (- paid refunded)
-          (order-recon-of events))))))
-
-(define
-  ledger-summaries
-  (fn (b) (map (fn (s) (order-summary b s)) (persist/backend-streams b))))
-
-;; --- relations over the summary set ---
-
-(define
-  summaryo
-  (fn
-    (summaries id total paid refunded net status)
-    (membero (list id total paid refunded net status) summaries)))
-
-(define
-  recon-statuso
-  (fn
-    (summaries id status)
-    (fresh (t p r n) (summaryo summaries id t p r n status))))
-
-(define
-  neto
-  (fn
-    (summaries id net)
-    (fresh (t p r status) (summaryo summaries id t p r net status))))
-
-;; A mismatch is any order whose money does not reconcile (over or under).
-(define
-  mismatcho
-  (fn
-    (summaries id)
-    (fresh
-      (status)
-      (recon-statuso summaries id status)
-      (conde ((== status :underpaid)) ((== status :overpaid))))))
-
-;; --- deterministic query helpers (run* over the live ledger) ---
-
-(define
-  orders-with-status
-  (fn (b status) (run* id (recon-statuso (ledger-summaries b) id status))))
-
-(define overpaid-orders (fn (b) (orders-with-status b :overpaid)))
-(define underpaid-orders (fn (b) (orders-with-status b :underpaid)))
-(define settled-orders (fn (b) (orders-with-status b :ok)))
-(define unpaid-orders (fn (b) (orders-with-status b :unpaid)))
-
-(define
-  mismatched-orders
-  (fn (b) (run* id (mismatcho (ledger-summaries b) id))))
-
-;; Backward: which order(s) settled to a given net amount?
-(define
-  orders-with-net
-  (fn (b net) (run* id (neto (ledger-summaries b) id net))))
-
-;; Total signed discrepancy across the ledger (net - total over paid orders);
-;; 0 when every settled order reconciles exactly.
-(define
-  ledger-discrepancy
-  (fn
-    (b)
-    (reduce
-      (fn
-        (acc s)
-        (let
-          ((status (nth s 5)))
-          (if
-            (= status :unpaid)
-            acc
-            (+ acc (- (nth s 4) (nth s 1))))))
-      0
-      (ledger-summaries b))))

lib/commerce/refund.sx

@@ -1,97 +0,0 @@
-;; lib/commerce/refund.sx — refund lifecycle as a second flow-on-sx flow.
-;;
-;; A refund is request → approve → settle, with TWO genuine suspension points:
-;; approval (a human/policy decision) and settlement (the provider issuing the
-;; refund). Like order.sx the flow is pure orchestration carrying only the
-;; order-id; the SX driver does all ledger IO and reuses order.sx's generic flow
-;; helpers (order-flow-waiting/-resume/-status, order-susp-id).
-;;
-;;   refund-begin!   → ledger :refund-requested, flow suspends at 'approve
-;;   refund-approve! → resume past approval, flow suspends at 'settle
-;;   refund-settle!  → ledger :refunded (idempotent), flow completes
-;;   refund-reject!  → ledger :refund-rejected, flow cancelled
-;;
-;; Only :refunded moves the books (recon.sx), so a requested-but-unsettled or
-;; rejected refund leaves reconciliation unchanged.
-
-(define
-  refund-flow-src
-  "(defflow refund-lifecycle (lambda (oid) (begin (request (quote approve) oid) (request (quote settle) oid))))")
-
-(define
-  refund-make-env
-  (fn
-    ()
-    (let
-      ((env (flow-make-env)))
-      (begin (flow-run-in env refund-flow-src) env))))
-
-;; Register the refund flow into an existing (e.g. order) env.
-(define
-  refund-flow-load!
-  (fn (env) (begin (flow-run-in env refund-flow-src) env)))
-
-(define
-  refund-flow-start
-  (fn
-    (env oid)
-    (flow-run-in env (str "(flow/start refund-lifecycle \"" oid "\")"))))
-
-;; --- ledger writes ---
-
-(define
-  refund-request
-  (fn
-    (b oid ref at amount)
-    (persist/append-once
-      b
-      (order-stream oid)
-      (str "refund-req/" ref)
-      :refund-requested at
-      {:amount amount :ref ref})))
-
-;; --- lifecycle ---
-
-;; Open a refund: record the request, start the flow, suspend at approval.
-(define
-  refund-begin!
-  (fn
-    (env b oid ref at amount)
-    (begin
-      (refund-request b oid ref at amount)
-      (order-susp-id (refund-flow-start env oid)))))
-
-(define
-  refund-approve!
-  (fn
-    (env id)
-    (if
-      (= (order-flow-waiting env id) "approve")
-      (begin (order-flow-resume env id :approved) :approved)
-      :not-pending-approval)))
-
-(define
-  refund-reject!
-  (fn
-    (env b oid id at reason)
-    (if
-      (= (order-flow-waiting env id) "approve")
-      (begin
-        (persist/append b (order-stream oid) :refund-rejected at {:reason reason})
-        (flow-run-in env (str "(flow/cancel " id ")"))
-        :rejected)
-      :not-pending-approval)))
-
-;; Settle (provider issued the refund): idempotent — only acts while waiting on
-;; settle, so a replayed provider callback returns :already-settled.
-(define
-  refund-settle!
-  (fn
-    (env b id oid ref at amount)
-    (if
-      (= (order-flow-waiting env id) "settle")
-      (begin
-        (order-refund b oid ref at amount)
-        (order-flow-resume env id :settled)
-        :settled)
-      :already-settled)))

lib/commerce/scoreboard.json

@@ -1,25 +0,0 @@
-{
-  "suites": {
-    "catalog": {"pass": 16, "fail": 0},
-    "cart": {"pass": 18, "fail": 0},
-    "price": {"pass": 20, "fail": 0},
-    "api": {"pass": 12, "fail": 0},
-    "promo": {"pass": 17, "fail": 0},
-    "stack": {"pass": 16, "fail": 0},
-    "quote": {"pass": 13, "fail": 0},
-    "ledger": {"pass": 20, "fail": 0},
-    "order": {"pass": 22, "fail": 0},
-    "recon": {"pass": 20, "fail": 0},
-    "federation": {"pass": 12, "fail": 0},
-    "attribution": {"pass": 16, "fail": 0},
-    "payment": {"pass": 7, "fail": 0},
-    "window": {"pass": 19, "fail": 0},
-    "nettax": {"pass": 11, "fail": 0},
-    "stock": {"pass": 19, "fail": 0},
-    "refund": {"pass": 20, "fail": 0},
-    "integration": {"pass": 19, "fail": 0}
-  },
-  "total_pass": 297,
-  "total_fail": 0,
-  "total": 297
-}

lib/commerce/scoreboard.md

@@ -1,25 +0,0 @@
-# commerce Conformance Scoreboard
-
-_Generated by `lib/commerce/conformance.sh`_
-
-| Suite | Pass | Fail | Total |
-|-------|-----:|-----:|------:|
-| catalog | 16 | 0 | 16 |
-| cart | 18 | 0 | 18 |
-| price | 20 | 0 | 20 |
-| api | 12 | 0 | 12 |
-| promo | 17 | 0 | 17 |
-| stack | 16 | 0 | 16 |
-| quote | 13 | 0 | 13 |
-| ledger | 20 | 0 | 20 |
-| order | 22 | 0 | 22 |
-| recon | 20 | 0 | 20 |
-| federation | 12 | 0 | 12 |
-| attribution | 16 | 0 | 16 |
-| payment | 7 | 0 | 7 |
-| window | 19 | 0 | 19 |
-| nettax | 11 | 0 | 11 |
-| stock | 19 | 0 | 19 |
-| refund | 20 | 0 | 20 |
-| integration | 19 | 0 | 19 |
-| **Total** | **297** | **0** | **297** |

lib/commerce/stack.sx

@@ -1,121 +0,0 @@
-;; lib/commerce/stack.sx — promotion stacking precedence + best price.
-;;
-;; Per the miniKanren design rule, precedence is NOT encoded inside the promo
-;; rules. promo.sx enumerates which promos apply; this layer enumerates which
-;; *combinations* are legal and selects the best one by an explicit cost
-;; function (max total discount = min price).
-;;
-;; Exclusivity is a list of unordered code pairs that may not both apply:
-;;   exclusions = (list (list code-a code-b) ...)
-;; A stacking is a subset of applicable (code amount) pairs containing no
-;; excluded pair. valid-stackings enumerates them; best-stacking is the
-;; deterministic selection layer; stacking-by-totalo is the backward query
-;; ("which legal stacking yields this total discount?").
-
-(define
-  excluded-pair?
-  (fn
-    (exclusions a b)
-    (some
-      (fn
-        (p)
-        (or
-          (and (= (first p) a) (= (nth p 1) b))
-          (and (= (first p) b) (= (nth p 1) a))))
-      exclusions)))
-
-;; True when no two distinct codes in the list are mutually excluded.
-(define
-  compatible?
-  (fn
-    (exclusions codes)
-    (every?
-      (fn
-        (a)
-        (every?
-          (fn (b) (or (= a b) (not (excluded-pair? exclusions a b))))
-          codes))
-      codes)))
-
-;; All subsets of xs, preserving element order. 2^n entries.
-(define
-  powerset
-  (fn
-    (xs)
-    (if
-      (empty? xs)
-      (list (list))
-      (let
-        ((r (powerset (cdr xs))))
-        (append r (map (fn (s) (cons (first xs) s)) r))))))
-
-(define stacking-codes (fn (st) (map first st)))
-
-(define
-  stacking-total
-  (fn
-    (st)
-    (reduce (fn (acc pair) (+ acc (nth pair 1))) 0 st)))
-
-;; Every legal stacking of the applicable (code amount) pairs.
-(define
-  valid-stackings
-  (fn
-    (exclusions applicable)
-    (filter
-      (fn (st) (compatible? exclusions (stacking-codes st)))
-      (powerset applicable))))
-
-;; Deterministic selection: the legal stacking with the greatest total
-;; discount; ties keep the earlier (stable) candidate, so the result is a
-;; reproducible function of (exclusions, applicable).
-(define
-  best-stacking
-  (fn
-    (exclusions applicable)
-    (reduce
-      (fn
-        (best st)
-        (if (> (stacking-total st) (stacking-total best)) st best))
-      (list)
-      (valid-stackings exclusions applicable))))
-
-(define
-  best-discount
-  (fn
-    (exclusions applicable)
-    (stacking-total (best-stacking exclusions applicable))))
-
-(define
-  best-codes
-  (fn
-    (exclusions applicable)
-    (stacking-codes (best-stacking exclusions applicable))))
-
-;; Backward query: legal stackings (as code lists) whose total discount = D.
-(define
-  stacking-by-totalo
-  (fn
-    (stackings codes total)
-    (fresh
-      (st)
-      (membero st stackings)
-      (project
-        (st)
-        (mk-conj
-          (== codes (stacking-codes st))
-          (== total (stacking-total st)))))))
-
-;; --- top-level entry: best discount for a cart under a ruleset ---
-
-(define
-  best-promo-discount
-  (fn
-    (ctx cart ruleset exclusions)
-    (best-discount exclusions (applicable-promos ctx cart ruleset))))
-
-(define
-  best-promo-codes
-  (fn
-    (ctx cart ruleset exclusions)
-    (best-codes exclusions (applicable-promos ctx cart ruleset))))

lib/commerce/stock.sx

@@ -1,106 +0,0 @@
-;; lib/commerce/stock.sx — stock-constrained reservation.
-;;
-;; Reservation is a precondition the host checks BEFORE order-begin! (validate →
-;; begin), so the order flow stays pure orchestration. Availability is read
-;; relationally from the catalog stock facts (catalog.sx stocko); a stock view
-;; subtracts already-reserved quantities so concurrent orders can't over-reserve.
-;;
-;;   can-reserve? cat cart                  — every line fits available stock
-;;   reservation-shortfalls cat cart        — the lines that do not, with detail
-;;   effective-available cat reservations …  — availability net of reservations
-;;   sufficient-stocko cat sku variant qty  — relational "can supply qty?" query
-
-;; Deterministic on-hand stock for a (sku,variant); 0 if absent.
-(define
-  available-stock
-  (fn
-    (cat sku variant)
-    (let
-      ((rs (run 1 q (stocko cat sku variant q))))
-      (if (empty? rs) 0 (first rs)))))
-
-;; Units a line cannot fulfil from on-hand stock (0 if it fits).
-(define
-  line-shortfall
-  (fn
-    (cat line)
-    (let
-      ((short (- (line-qty line) (available-stock cat (line-sku line) (line-variant line)))))
-      (if (< short 0) 0 short))))
-
-(define
-  line-reservable?
-  (fn (cat line) (= (line-shortfall cat line) 0)))
-
-;; Lines that cannot be fully reserved, each with requested/available/short.
-(define
-  reservation-shortfalls
-  (fn
-    (cat cart)
-    (reduce
-      (fn
-        (acc line)
-        (let
-          ((short (line-shortfall cat line)))
-          (if (> short 0) (append acc (list {:requested (line-qty line) :available (available-stock cat (line-sku line) (line-variant line)) :sku (line-sku line) :variant (line-variant line) :short short})) acc)))
-      (list)
-      cart)))
-
-(define
-  can-reserve?
-  (fn (cat cart) (empty? (reservation-shortfalls cat cart))))
-
-;; Validate → reject; the host gates order-begin! on this.
-(define
-  reserve-check
-  (fn (cat cart) (if (can-reserve? cat cart) :ok {:shortfalls (reservation-shortfalls cat cart) :rejected :insufficient-stock})))
-
-;; --- reservation view (concurrent-safety) ---
-;; reservations: list of (sku variant qty) already held.
-
-(define
-  reserved-qty
-  (fn
-    (reservations sku variant)
-    (reduce
-      (fn
-        (acc r)
-        (if
-          (and (= (first r) sku) (= (nth r 1) variant))
-          (+ acc (nth r 2))
-          acc))
-      0
-      reservations)))
-
-;; On-hand minus already-reserved (clamped at 0).
-(define
-  effective-available
-  (fn
-    (cat reservations sku variant)
-    (let
-      ((eff (- (available-stock cat sku variant) (reserved-qty reservations sku variant))))
-      (if (< eff 0) 0 eff))))
-
-;; Can a line be reserved given existing reservations?
-(define
-  line-reservable-with?
-  (fn
-    (cat reservations line)
-    (<=
-      (line-qty line)
-      (effective-available
-        cat
-        reservations
-        (line-sku line)
-        (line-variant line)))))
-
-;; --- relational availability query (the showcase) ---
-
-;; Succeeds when on-hand stock for (sku,variant) covers qty. Multidirectional
-;; over the stock facts: "which variants of widget can supply 5?" is a backward
-;; query.
-(define
-  sufficient-stocko
-  (fn
-    (cat sku variant qty)
-    (fresh (avail) (stocko cat sku variant avail) (lteo-i qty avail))))

lib/commerce/tests/api.sx

@@ -1,73 +0,0 @@
-;; lib/commerce/tests/api.sx — public commerce session surface.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  acat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "book" 800 :zero-rated))
-    (list (list "widget" :small -200))
-    (list)))
-
-(define
-  arules
-  (list
-    (list :uk :standard :guest 2000)
-    (list :uk :zero-rated :guest 0)))
-
-(define actx (make-pricing-context acat arules :uk :guest))
-(define sess0 (commerce-session actx))
-
-;; --- empty session ---
-
-(commerce-test "new-session-empty" (commerce-cart sess0) empty-cart)
-(commerce-test "new-count" (commerce-count sess0) 0)
-(commerce-test "new-total" (commerce-total sess0) {:subtotal 0 :discounts 0 :total 0 :tax 0})
-
-;; --- add + total ---
-
-(define
-  sess1
-  (commerce-add
-    (commerce-add sess0 "widget" :small 2)
-    "book"
-    :none 1))
-
-(commerce-test "add-count" (commerce-count sess1) 3)
-(commerce-test
-  "add-lines"
-  (commerce-lines sess1)
-  (list (list "widget" :small 2) (list "book" :none 1)))
-(commerce-test "add-total" (commerce-total sess1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
-
-;; --- mutate ---
-
-(commerce-test
-  "set-qty"
-  (commerce-lines (commerce-set-qty sess1 "widget" :small 1))
-  (list (list "widget" :small 1) (list "book" :none 1)))
-
-(commerce-test
-  "remove"
-  (commerce-lines (commerce-remove sess1 "book" :none))
-  (list (list "widget" :small 2)))
-
-;; --- validation ---
-
-(commerce-test "can-add-yes" (commerce-can-add? sess0 "widget") true)
-(commerce-test "can-add-no" (commerce-can-add? sess0 "ghost") false)
-
-;; --- audit breakdown ---
-
-(commerce-test
-  "explain"
-  (commerce-explain sess1)
-  (list {:sku "widget" :unit 800 :qty 2 :variant :small :extended 1600 :tax 320} {:sku "book" :unit 800 :qty 1 :variant :none :extended 800 :tax 0}))
-
-;; --- checkout stub ---
-
-(commerce-test
-  "checkout-stub"
-  (get (commerce-checkout sess1) :status)
-  :not-implemented)

lib/commerce/tests/attribution.sx

@@ -1,124 +0,0 @@
-;; lib/commerce/tests/attribution.sx — line-level discount attribution.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  pcat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "gizmo" 2000 :standard)
-      (list "book" 800 :zero-rated)
-      (list "tea" 1000 :reduced))
-    (list)
-    (list)))
-
-(define gctx (make-pricing-context pcat (list) :uk :guest))
-(define mctx (make-pricing-context pcat (list) :uk :member))
-
-(define
-  cart
-  (list
-    (list "widget" :none 2)
-    (list "gizmo" :none 1)
-    (list "book" :none 1)
-    (list "tea" :none 6)))
-
-(define
-  ruleset
-  (list
-    (list :percent "TEN" :standard 1000)
-    (list :percent "TWENTY" :standard 2000)
-    (list :bundle "B3T" "tea" 3)
-    (list :fixed "FIVE" 0 500)
-    (list :member "MEM" :standard 1500)))
-
-(define w-line (list "widget" :none 2))
-(define t-line (list "tea" :none 6))
-(define bk-line (list "book" :none 1))
-
-;; --- scope helpers ---
-
-(commerce-test
-  "class-lines-standard"
-  (class-lines gctx cart :standard)
-  (list (list "widget" :none 2) (list "gizmo" :none 1)))
-
-(commerce-test
-  "promo-lines-bundle"
-  (promo-lines gctx cart (list :bundle "B3T" "tea" 3))
-  (list (list "tea" :none 6)))
-
-(commerce-test
-  "promo-lines-fixed-none"
-  (promo-lines gctx cart (list :fixed "FIVE" 0 500))
-  (list))
-
-;; --- forward: which lines does a code touch? ---
-
-(commerce-test
-  "lines-for-ten"
-  (lines-for-code gctx cart ruleset "TEN")
-  (list (list "widget" :none 2) (list "gizmo" :none 1)))
-
-(commerce-test
-  "lines-for-bundle"
-  (lines-for-code gctx cart ruleset "B3T")
-  (list (list "tea" :none 6)))
-
-(commerce-test
-  "lines-for-fixed-empty"
-  (lines-for-code gctx cart ruleset "FIVE")
-  (list))
-(commerce-test
-  "lines-for-mem-guest-empty"
-  (lines-for-code gctx cart ruleset "MEM")
-  (list))
-
-;; --- backward: which codes touch this line? (the showcase) ---
-
-(commerce-test
-  "codes-for-widget-guest"
-  (codes-for-line gctx cart ruleset w-line)
-  (list "TEN" "TWENTY"))
-
-(commerce-test
-  "codes-for-tea"
-  (codes-for-line gctx cart ruleset t-line)
-  (list "B3T"))
-(commerce-test
-  "codes-for-book-none"
-  (codes-for-line gctx cart ruleset bk-line)
-  (list))
-
-;; member sees the member rate too
-(commerce-test
-  "codes-for-widget-member"
-  (codes-for-line mctx cart ruleset w-line)
-  (list "TEN" "TWENTY" "MEM"))
-
-(commerce-test
-  "lines-for-mem-member"
-  (lines-for-code mctx cart ruleset "MEM")
-  (list (list "widget" :none 2) (list "gizmo" :none 1)))
-
-;; --- predicate ---
-
-(commerce-test
-  "touched-yes"
-  (line-touched-by? gctx cart ruleset "TEN" w-line)
-  true)
-(commerce-test
-  "touched-no-wrong-class"
-  (line-touched-by? gctx cart ruleset "B3T" w-line)
-  false)
-(commerce-test
-  "touched-no-guest-mem"
-  (line-touched-by? gctx cart ruleset "MEM" w-line)
-  false)
-
-;; --- order-level (fixed) codes ---
-
-(commerce-test
-  "order-level"
-  (order-level-codes gctx cart ruleset)
-  (list "FIVE"))

lib/commerce/tests/cart.sx

@@ -1,103 +0,0 @@
-;; lib/commerce/tests/cart.sx — cart structure + line operations.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-;; --- add ---
-
-(commerce-test
-  "add-to-empty"
-  (cart-add empty-cart "widget" :small 2)
-  (list (list "widget" :small 2)))
-
-(commerce-test
-  "add-merges-same-line"
-  (cart-add
-    (cart-add empty-cart "widget" :small 2)
-    "widget"
-    :small 3)
-  (list (list "widget" :small 5)))
-
-(commerce-test
-  "add-different-variant-separate"
-  (cart-add
-    (cart-add empty-cart "widget" :small 2)
-    "widget"
-    :large 1)
-  (list (list "widget" :small 2) (list "widget" :large 1)))
-
-(commerce-test
-  "add-different-sku-separate"
-  (cart-add
-    (cart-add empty-cart "widget" :small 2)
-    "gadget"
-    :std 1)
-  (list (list "widget" :small 2) (list "gadget" :std 1)))
-
-(commerce-test
-  "add-preserves-order"
-  (cart-skus
-    (cart-add
-      (cart-add (cart-add empty-cart "a" :v 1) "b" :v 1)
-      "c"
-      :v 1))
-  (list "a" "b" "c"))
-
-;; --- qty queries ---
-
-(define
-  c2
-  (cart-add
-    (cart-add empty-cart "widget" :small 2)
-    "gadget"
-    :std 4))
-
-(commerce-test "cart-qty-found" (cart-qty c2 "widget" :small) 2)
-(commerce-test "cart-qty-missing" (cart-qty c2 "widget" :large) 0)
-(commerce-test "cart-count" (cart-count c2) 6)
-(commerce-test "cart-empty-yes" (cart-empty? empty-cart) true)
-(commerce-test "cart-empty-no" (cart-empty? c2) false)
-
-;; --- set-qty ---
-
-(commerce-test
-  "set-qty-existing"
-  (cart-set-qty c2 "widget" :small 10)
-  (list (list "widget" :small 10) (list "gadget" :std 4)))
-
-(commerce-test
-  "set-qty-new-line"
-  (cart-set-qty empty-cart "book" :std 3)
-  (list (list "book" :std 3)))
-
-(commerce-test
-  "set-qty-zero-removes"
-  (cart-set-qty c2 "widget" :small 0)
-  (list (list "gadget" :std 4)))
-
-;; --- remove ---
-
-(commerce-test
-  "remove-line"
-  (cart-remove c2 "gadget" :std)
-  (list (list "widget" :small 2)))
-
-(commerce-test
-  "remove-missing-noop"
-  (cart-remove c2 "nope" :std)
-  (list (list "widget" :small 2) (list "gadget" :std 4)))
-
-;; --- relational view ---
-
-(commerce-test
-  "cart-lineo-forward"
-  (run* q (cart-lineo c2 "gadget" :std q))
-  (list 4))
-
-(commerce-test
-  "cart-lineo-sku-by-qty-backward"
-  (run* sk (fresh (v) (cart-lineo c2 sk v 4)))
-  (list "gadget"))
-
-(commerce-test
-  "cart-lineo-all-skus"
-  (run* sk (fresh (v q) (cart-lineo c2 sk v q)))
-  (list "widget" "gadget"))

lib/commerce/tests/catalog.sx

@@ -1,93 +0,0 @@
-;; lib/commerce/tests/catalog.sx — catalog facts + relational accessors.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-;; Query vars avoid the name `s` (the run-n macro binds `s` internally).
-
-(define
-  cat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "gadget" 2500 :standard)
-      (list "book" 800 :zero-rated)
-      (list "tea" 1000 :reduced))
-    (list
-      (list "widget" :small -200)
-      (list "widget" :large 500)
-      (list "gadget" :std 0))
-    (list
-      (list "widget" :small 5)
-      (list "widget" :large 0)
-      (list "gadget" :std 12))))
-
-;; --- forward lookups ---
-
-(commerce-test
-  "price-forward"
-  (run* p (priceo cat "widget" p))
-  (list 1000))
-(commerce-test
-  "class-forward"
-  (run* c (classo cat "book" c))
-  (list :zero-rated))
-(commerce-test
-  "product-forward"
-  (run* q (fresh (p c) (producto cat "gadget" p c) (== q (list p c))))
-  (list (list 2500 :standard)))
-
-;; --- backward lookups (the showcase) ---
-
-(commerce-test
-  "sku-by-price-backward"
-  (run* sk (priceo cat sk 1000))
-  (list "widget" "tea"))
-
-(commerce-test
-  "sku-by-class-backward"
-  (run* sk (classo cat sk :standard))
-  (list "widget" "gadget"))
-
-(commerce-test
-  "all-prices"
-  (run* p (fresh (sk) (priceo cat sk p)))
-  (list 1000 2500 800 1000))
-
-;; --- variants + effective unit price ---
-
-(commerce-test
-  "variant-delta-forward"
-  (run* d (varianto cat "widget" :small d))
-  (list -200))
-
-(commerce-test
-  "unit-price-small"
-  (run* p (unit-priceo cat "widget" :small p))
-  (list 800))
-
-(commerce-test
-  "unit-price-large"
-  (run* p (unit-priceo cat "widget" :large p))
-  (list 1500))
-
-(commerce-test
-  "variant-by-delta-backward"
-  (run* v (varianto cat "widget" v -200))
-  (list :small))
-
-;; --- stock ---
-
-(commerce-test
-  "stock-forward"
-  (run* q (stocko cat "widget" :small q))
-  (list 5))
-
-(commerce-test
-  "in-stock-skus-backward"
-  (run* sk (fresh (v q) (stocko cat sk v q) (lto-i 0 q)))
-  (list "widget" "gadget"))
-
-;; --- deterministic helpers ---
-
-(commerce-test "catalog-price-helper" (catalog-price cat "gadget") 2500)
-(commerce-test "catalog-class-helper" (catalog-class cat "tea") :reduced)
-(commerce-test "catalog-has-yes" (catalog-has? cat "book") true)
-(commerce-test "catalog-has-no" (catalog-has? cat "nonesuch") false)

lib/commerce/tests/federation.sx

@@ -1,88 +0,0 @@
-;; lib/commerce/tests/federation.sx — federated catalog (out-of-scope stub).
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  cat-a
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "book" 800 :zero-rated))
-    (list)
-    (list)))
-
-(define
-  cat-b
-  (make-catalog
-    (list
-      (list "widget" 900 :standard)
-      (list "tea" 1200 :reduced))
-    (list)
-    (list)))
-
-(define
-  cat-c
-  (make-catalog (list (list "widget" 1100 :standard)) (list) (list)))
-
-(define
-  fed
-  (federation-add
-    (federation-add (make-federation :alpha cat-a) :beta cat-b)
-    :gamma cat-c))
-
-;; --- structure ---
-
-(commerce-test "is-stub" federation-stub? true)
-(commerce-test
-  "instances"
-  (federation-instances fed)
-  (list :alpha :beta :gamma))
-(commerce-test "product-count" (len (fed-products fed)) 5)
-
-;; --- forward query ---
-
-(commerce-test
-  "price-at-instance"
-  (run* p (fed-priceo fed :beta "widget" p))
-  (list 900))
-
-;; --- backward queries (the showcase) ---
-
-(commerce-test
-  "instances-with-widget"
-  (instances-with-sku fed "widget")
-  (list :alpha :beta :gamma))
-
-(commerce-test
-  "instances-with-book"
-  (instances-with-sku fed "book")
-  (list :alpha))
-
-(commerce-test
-  "instances-with-tea"
-  (instances-with-sku fed "tea")
-  (list :beta))
-
-(commerce-test
-  "instance-by-price-backward"
-  (run* inst (fresh (c) (fed-producto fed inst "widget" 1100 c)))
-  (list :gamma))
-
-;; --- offers + cheapest (deterministic selection) ---
-
-(commerce-test
-  "widget-offers"
-  (sku-offers fed "widget")
-  (list
-    (list 1000 :alpha)
-    (list 900 :beta)
-    (list 1100 :gamma)))
-
-(commerce-test
-  "cheapest-widget"
-  (cheapest-offer fed "widget")
-  (list 900 :beta))
-(commerce-test
-  "cheapest-book"
-  (cheapest-offer fed "book")
-  (list 800 :alpha))
-(commerce-test "cheapest-missing" (cheapest-offer fed "ghost") nil)

lib/commerce/tests/integration.sx

@@ -1,104 +0,0 @@
-;; lib/commerce/tests/integration.sx — end-to-end composition proof.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-;;
-;; One narrative across every module: catalog → stock check → quote
-;; (promo+stack+tax) → order flow → payment envelope → settle → recon → refund.
-;; Proves the seams tie together with consistent numbers (the project's thesis:
-;; minikanren pricing + flow lifecycle + persist ledger compose).
-;; Builds one flow env with BOTH the order and refund flows.
-
-(define env (order-make-env))
-(define _rf (refund-flow-load! env))
-(define b (persist/mem-backend))
-
-(define
-  cat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "book" 800 :zero-rated))
-    (list (list "widget" :small -200))
-    (list (list "widget" :small 10) (list "book" :none 5))))
-
-(define
-  rules
-  (list
-    (list :uk :standard :guest 2000)
-    (list :uk :zero-rated :guest 0)))
-
-(define ctx (make-pricing-context cat rules :uk :guest))
-
-(define
-  ruleset
-  (list
-    (list :percent "TEN" :standard 1000)
-    (list :fixed "FIVE" 0 50)))
-
-;; widget :small x2 → unit 800, extended 1600 (standard); book x1 → 800 (zero-rated)
-(define
-  cart
-  (list (list "widget" :small 2) (list "book" :none 1)))
-
-;; 1. stock gating passes (widget:small 10 >= 2)
-(commerce-test "int-can-reserve" (can-reserve? cat cart) true)
-
-;; 2. quote ties the whole pricing pipeline together
-;;    subtotal 2400; discount TEN 160 + FIVE 50 = 210; tax 1600@20% = 320;
-;;    total 2400 - 210 + 320 = 2510
-(define q (cart-quote ctx cart ruleset (list)))
-(commerce-test "int-quote-subtotal" (quote-subtotal q) 2400)
-(commerce-test "int-quote-discount" (quote-discount q) 210)
-(commerce-test "int-quote-tax" (quote-tax q) 320)
-(commerce-test "int-quote-total" (quote-total q) 2510)
-
-;; 3. attribution explains where the discount landed
-(commerce-test
-  "int-attribution"
-  (codes-for-line ctx cart ruleset (list "widget" :small 2))
-  (list "TEN"))
-(commerce-test
-  "int-order-level"
-  (order-level-codes ctx cart ruleset)
-  (list "FIVE"))
-
-;; 4. order carries the quote total into the ledger; suspends at payment
-(define oid "INT-1")
-(define id (order-begin! env b oid 1000 q))
-(commerce-test "int-order-total-from-quote" (order-total b oid) 2510)
-(commerce-test "int-waiting-payment" (order-flow-waiting env id) "payment")
-
-;; 5. the payment envelope reflects the quoted total
-(commerce-test
-  "int-payment-envelope"
-  (payment-request b oid :GBP "https://shop/return")
-  {:order "INT-1" :amount 2510 :return-url "https://shop/return" :currency :GBP})
-
-;; 6. settle the quoted amount → reconciles exactly
-(commerce-test
-  "int-settled"
-  (order-settle! env b id oid "pay-int" 1002 2510)
-  :settled)
-(commerce-test "int-status-fulfilled" (order-status b oid) :fulfilled)
-(commerce-test "int-recon-ok" (order-recon b oid) :ok)
-
-;; 7. partial refund via its own flow → recon moves to underpaid
-(define rid (refund-begin! env b oid "rf-int" 2000 510))
-(commerce-test "int-refund-approve" (refund-approve! env rid) :approved)
-(commerce-test
-  "int-refund-settle"
-  (refund-settle! env b rid oid "rf-int" 2001 510)
-  :settled)
-(commerce-test
-  "int-refunded-amount"
-  (order-refunded-amount-of (order-events b oid))
-  510)
-(commerce-test "int-recon-after-refund" (order-recon b oid) :underpaid)
-
-;; 8. ledger reconciliation flags the now-mismatched order
-(commerce-test
-  "int-mismatch"
-  (mismatched-orders b)
-  (list (order-stream "INT-1")))
-
-;; 9. distinct flow ids for the order and the refund
-(commerce-test "int-distinct-flow-ids" (not (= id rid)) true)

lib/commerce/tests/ledger.sx

@@ -1,80 +0,0 @@
-;; lib/commerce/tests/ledger.sx — order ledger on persist + idempotent recon.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
-
-;; --- lifecycle status projection ---
-
-(define b1 (persist/mem-backend))
-(define _c1 (order-create b1 "A1" 100 q1))
-(commerce-test "status-pending" (order-status b1 "A1") :pending)
-(define _r1 (order-reserve b1 "A1" 101 {:lines 2}))
-(commerce-test "status-reserved" (order-status b1 "A1") :reserved)
-(define _p1 (order-pay b1 "A1" "ref-1" 102 1200))
-(commerce-test "status-paid" (order-status b1 "A1") :paid)
-(define _f1 (order-fulfil b1 "A1" 103 {:carrier "post"}))
-(commerce-test "status-fulfilled" (order-status b1 "A1") :fulfilled)
-
-(commerce-test "total-projection" (order-total b1 "A1") 1200)
-(commerce-test "paid-projection" (order-paid b1 "A1") 1200)
-(commerce-test "recon-ok" (order-recon b1 "A1") :ok)
-(commerce-test "event-count" (len (order-events b1 "A1")) 4)
-
-;; --- idempotency: replayed webhook does not double-record ---
-
-(define b2 (persist/mem-backend))
-(define _c2 (order-create b2 "B1" 200 q1))
-(define _p2a (order-pay b2 "B1" "sumup-9" 201 1200))
-(define _p2b (order-pay b2 "B1" "sumup-9" 201 1200))
-(define _p2c (order-pay b2 "B1" "sumup-9" 201 1200))
-
-(commerce-test "idem-single-event" (len (order-events b2 "B1")) 2)
-(commerce-test "idem-paid-once" (order-paid b2 "B1") 1200)
-(commerce-test "idem-recon-ok" (order-recon b2 "B1") :ok)
-(commerce-test "idem-same-event" (= _p2a _p2c) true)
-
-;; --- mismatch detection ---
-
-(define bun (persist/mem-backend))
-(define _cu (order-create bun "U1" 300 q1))
-(commerce-test "unpaid-recon" (order-recon bun "U1") :unpaid)
-
-(define bup (persist/mem-backend))
-(define _cp (order-create bup "U2" 300 q1))
-(define _pp1 (order-pay bup "U2" "r-a" 301 1200))
-(define _pp2 (order-pay bup "U2" "r-b" 302 1200))
-(commerce-test "double-charge-overpaid" (order-recon bup "U2") :overpaid)
-(commerce-test "double-charge-amount" (order-paid bup "U2") 2400)
-
-(define bsh (persist/mem-backend))
-(define _cs (order-create bsh "U3" 400 q1))
-(define _ps (order-pay bsh "U3" "r-short" 401 1000))
-(commerce-test "underpaid-recon" (order-recon bsh "U3") :underpaid)
-
-;; --- refund (idempotent) reduces net ---
-
-(define brf (persist/mem-backend))
-(define _crf (order-create brf "R1" 500 q1))
-(define _prf (order-pay brf "R1" "p-1" 501 1200))
-(define _rf1 (order-refund brf "R1" "rf-1" 502 200))
-(define _rf2 (order-refund brf "R1" "rf-1" 502 200))
-(commerce-test "refund-idem-net" (order-recon brf "R1") :underpaid)
-(commerce-test "refund-idem-events" (len (order-events brf "R1")) 3)
-
-;; --- cross-ledger reconciliation ---
-
-(define bL (persist/mem-backend))
-(define _l1 (order-create bL "OK1" 600 q1))
-(define _l1p (order-pay bL "OK1" "ok-ref" 601 1200))
-(define _l2 (order-create bL "OVER1" 600 q1))
-(define _l2a (order-pay bL "OVER1" "o-a" 602 1200))
-(define _l2b (order-pay bL "OVER1" "o-b" 603 1200))
-(define _l3 (order-create bL "UNDER1" 600 q1))
-(define _l3p (order-pay bL "UNDER1" "u-ref" 604 900))
-(define _l4 (order-create bL "PENDING1" 600 q1))
-
-(commerce-test "ledger-order-count" (len (order-ids bL)) 4)
-(commerce-test
-  "ledger-mismatches"
-  (sort (ledger-mismatches bL))
-  (sort (list (order-stream "OVER1") (order-stream "UNDER1"))))

lib/commerce/tests/nettax.sx

@@ -1,92 +0,0 @@
-;; lib/commerce/tests/nettax.sx — discount-aware (net) tax policy.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  pcat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "tea" 1000 :reduced))
-    (list)
-    (list)))
-
-(define
-  rules
-  (list
-    (list :uk :standard :guest 2000)
-    (list :uk :reduced :guest 500)))
-
-(define gctx (make-pricing-context pcat rules :uk :guest))
-
-;; widget x3 = 3000 (standard), tea x6 = 6000 (reduced); subtotal 9000
-(define
-  cart
-  (list (list "widget" :none 3) (list "tea" :none 6)))
-
-(define ruleset (list (list :percent "TEN" :standard 1000)))
-
-;; --- allocation: proportional, sums exactly to the discount ---
-
-(commerce-test
-  "allocate-even"
-  (allocate-discount pcat cart 300)
-  (list 100 200))
-(commerce-test
-  "allocate-sums-to-discount"
-  (ct-sum (allocate-discount pcat cart 300))
-  300)
-
-;; remainder distribution: 100 over (3000,6000)/9000 = (33,66) rem 1 -> (34,66)
-(commerce-test
-  "allocate-remainder"
-  (allocate-discount pcat cart 100)
-  (list 34 66))
-(commerce-test
-  "allocate-remainder-sums"
-  (ct-sum (allocate-discount pcat cart 100))
-  100)
-
-(commerce-test
-  "allocate-zero"
-  (allocate-discount pcat cart 0)
-  (list 0 0))
-(commerce-test
-  "allocate-empty"
-  (allocate-discount pcat empty-cart 0)
-  (list))
-
-;; --- net tax vs gross tax ---
-;; discount = TEN 10% of standard 3000 = 300, allocated (100 200).
-;; net: widget 2900@20%=580, tea 5800@5%=290 -> net tax 870 (gross was 900).
-
-(commerce-test
-  "net-quote"
-  (cart-quote-net gctx cart ruleset (list))
-  {:codes (list "TEN") :subtotal 9000 :discount 300 :total 9570 :tax 870})
-
-;; same cart through the gross policy taxes 900 (the documented default)
-(commerce-test
-  "gross-quote-for-contrast"
-  (quote-tax (cart-quote gctx cart ruleset (list)))
-  900)
-
-(commerce-test
-  "net-tax-lower"
-  (quote-tax (cart-quote-net gctx cart ruleset (list)))
-  870)
-
-;; --- no discount: net policy == gross policy ---
-
-(commerce-test
-  "no-discount-net-equals-gross"
-  (=
-    (cart-quote-net gctx cart (list) (list))
-    (cart-quote gctx cart (list) (list)))
-  true)
-
-;; --- empty cart ---
-
-(commerce-test
-  "net-empty"
-  (cart-quote-net gctx empty-cart ruleset (list))
-  {:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})

lib/commerce/tests/order.sx

@@ -1,74 +0,0 @@
-;; lib/commerce/tests/order.sx — order lifecycle as a flow-on-sx flow.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-;; Builds the (expensive) flow env once; all assertions share it.
-
-(define env (order-make-env))
-(define b (persist/mem-backend))
-(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
-
-;; --- happy path: begin suspends at payment ---
-
-(define id1 (order-begin! env b "O1" 100 q1))
-
-(commerce-test "begin-status-reserved" (order-status b "O1") :reserved)
-(commerce-test "begin-waiting-payment" (order-flow-waiting env id1) "payment")
-(commerce-test "begin-not-yet-paid" (order-paid b "O1") 0)
-
-;; --- settle: payment webhook drives fulfilment ---
-
-(define s1 (order-settle! env b id1 "O1" "ref-1" 102 1200))
-
-(commerce-test "settle-result" s1 :settled)
-(commerce-test "settle-status-fulfilled" (order-status b "O1") :fulfilled)
-(commerce-test "settle-flow-done" (order-flow-status env id1) "done")
-(commerce-test "settle-recon-ok" (order-recon b "O1") :ok)
-(commerce-test "settle-event-count" (len (order-events b "O1")) 4)
-
-;; --- webhook replay: a second settle is a no-op ---
-
-(define s1b (order-settle! env b id1 "O1" "ref-1" 102 1200))
-
-(commerce-test "replay-already-settled" s1b :already-settled)
-(commerce-test
-  "replay-no-extra-events"
-  (len (order-events b "O1"))
-  4)
-(commerce-test "replay-recon-still-ok" (order-recon b "O1") :ok)
-
-;; --- a second order gets its own flow id and suspends independently ---
-
-(define id2 (order-begin! env b "O2" 200 q1))
-
-(commerce-test "second-distinct-id" (not (= id1 id2)) true)
-(commerce-test
-  "second-waiting-payment"
-  (order-flow-waiting env id2)
-  "payment")
-(commerce-test "first-unaffected" (order-status b "O1") :fulfilled)
-
-;; --- durability: a suspended order survives a process restart ---
-
-(define id3 (order-begin! env b "O3" 300 q1))
-(commerce-test "pre-restart-waiting" (order-flow-waiting env id3) "payment")
-
-(define _restart (order-flow-restart! env))
-
-(commerce-test
-  "post-restart-still-waiting"
-  (order-flow-waiting env id3)
-  "payment")
-(commerce-test "post-restart-ledger-intact" (order-status b "O3") :reserved)
-
-(define s3 (order-settle! env b id3 "O3" "ref-3" 302 1200))
-
-(commerce-test "post-restart-settled" s3 :settled)
-(commerce-test "post-restart-status" (order-status b "O3") :fulfilled)
-(commerce-test "post-restart-recon-ok" (order-recon b "O3") :ok)
-(commerce-test "post-restart-flow-done" (order-flow-status env id3) "done")
-
-;; --- payment-request envelope (provider-neutral) for the still-suspended O2 ---
-
-(commerce-test
-  "pending-payments-lists-suspended"
-  (pending-payments env b :GBP "https://shop/return")
-  (list {:id id2 :request {:order "O2" :amount 1200 :return-url "https://shop/return" :currency :GBP}}))

lib/commerce/tests/payment.sx

@@ -1,43 +0,0 @@
-;; lib/commerce/tests/payment.sx — provider-neutral payment-request envelope.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-;; Envelope construction is ledger-only (no flow env); pending-payments (which
-;; needs the flow env) is exercised in the order suite.
-
-(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
-(define q2 {:codes (list) :subtotal 5000 :discount 500 :total 4500 :tax 0})
-
-(define b (persist/mem-backend))
-(define _c1 (order-create b "P1" 1 q1))
-(define _c2 (order-create b "P2" 1 q2))
-
-(commerce-test
-  "envelope"
-  (payment-request b "P1" :GBP "https://shop/return")
-  {:order "P1" :amount 1200 :return-url "https://shop/return" :currency :GBP})
-
-(commerce-test
-  "envelope-amount"
-  (payment-request-amount (payment-request b "P1" :GBP "x"))
-  1200)
-(commerce-test
-  "envelope-currency"
-  (payment-request-currency (payment-request b "P1" :GBP "x"))
-  :GBP)
-(commerce-test
-  "envelope-order"
-  (payment-request-order (payment-request b "P1" :GBP "x"))
-  "P1")
-(commerce-test
-  "envelope-return-url"
-  (payment-request-return-url (payment-request b "P1" :GBP "https://r"))
-  "https://r")
-
-;; amount tracks the ledger total, currency is per-call (provider/instance config)
-(commerce-test
-  "envelope-amount-2"
-  (payment-request-amount (payment-request b "P2" :EUR "x"))
-  4500)
-(commerce-test
-  "envelope-currency-2"
-  (payment-request-currency (payment-request b "P2" :EUR "x"))
-  :EUR)

lib/commerce/tests/price.sx

@@ -1,100 +0,0 @@
-;; lib/commerce/tests/price.sx — subtotal + jurisdiction-relational tax.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  pcat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "book" 800 :zero-rated)
-      (list "tea" 1000 :reduced))
-    (list
-      (list "widget" :small -200)
-      (list "widget" :large 500))
-    (list)))
-
-(define
-  rules
-  (list
-    (list :uk :standard :guest 2000)
-    (list :uk :reduced :guest 500)
-    (list :uk :zero-rated :guest 0)
-    (list :uk :standard :member 1000)
-    (list :ie :standard :guest 2300)))
-
-(define gctx (make-pricing-context pcat rules :uk :guest))
-(define mctx (make-pricing-context pcat rules :uk :member))
-
-;; --- unit + line pricing ---
-
-(commerce-test
-  "unit-price-variant"
-  (line-unit-price pcat "widget" :small)
-  800)
-(commerce-test
-  "unit-price-no-variant"
-  (line-unit-price pcat "widget" :none)
-  1000)
-(commerce-test "unit-price-unknown" (line-unit-price pcat "ghost" :none) nil)
-(commerce-test
-  "line-extended"
-  (line-extended pcat (list "widget" :small 2))
-  1600)
-
-;; --- subtotal ---
-
-(define
-  cart1
-  (list (list "widget" :small 2) (list "book" :none 1)))
-
-(commerce-test "subtotal" (cart-subtotal pcat cart1) 2400)
-(commerce-test "subtotal-empty" (cart-subtotal pcat empty-cart) 0)
-
-;; --- tax rate lookup (relational, both directions) ---
-
-(commerce-test
-  "rate-forward"
-  (rate-bps rules :uk :standard :guest)
-  2000)
-(commerce-test
-  "rate-missing"
-  (rate-bps rules :fr :standard :guest)
-  0)
-(commerce-test
-  "rate-juris-by-bps-backward"
-  (run* j (fresh (cust) (taxo rules j :standard cust 2300)))
-  (list :ie))
-(commerce-test
-  "rate-customer-by-bps-backward"
-  (run* cust (taxo rules :uk :standard cust 1000))
-  (list :member))
-
-;; --- apply-bps rounding (half up, integer only) ---
-
-(commerce-test "bps-exact" (apply-bps 1600 2000) 320)
-(commerce-test "bps-round-up" (apply-bps 799 2000) 160)
-(commerce-test "bps-zero" (apply-bps 800 0) 0)
-
-;; --- line + cart tax ---
-
-(commerce-test
-  "line-tax-standard"
-  (line-tax gctx (list "widget" :small 2))
-  320)
-(commerce-test
-  "line-tax-zero-rated"
-  (line-tax gctx (list "book" :none 1))
-  0)
-(commerce-test
-  "line-tax-member"
-  (line-tax mctx (list "widget" :small 2))
-  160)
-(commerce-test "cart-tax-guest" (cart-tax gctx cart1) 320)
-
-;; --- total dict (deterministic) ---
-
-(commerce-test "total-guest" (cart-total gctx cart1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
-
-(commerce-test "total-member" (cart-total mctx cart1) {:subtotal 2400 :discounts 0 :total 2560 :tax 160})
-
-(commerce-test "total-empty" (cart-total gctx empty-cart) {:subtotal 0 :discounts 0 :total 0 :tax 0})

lib/commerce/tests/promo.sx

@@ -1,142 +0,0 @@
-;; lib/commerce/tests/promo.sx — promo rules + relational enumeration.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  pcat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "book" 800 :zero-rated)
-      (list "tea" 1000 :reduced))
-    (list)
-    (list)))
-
-(define gctx (make-pricing-context pcat (list) :uk :guest))
-(define mctx (make-pricing-context pcat (list) :uk :member))
-
-(define
-  cart
-  (list
-    (list "widget" :none 3)
-    (list "book" :none 1)
-    (list "tea" :none 6)))
-
-(define
-  ruleset
-  (list
-    (list :percent "TEN" :standard 1000)
-    (list :fixed "FIVER" 5000 500)
-    (list :bundle "B3T" "tea" 3)
-    (list :member "MEM" :standard 1500)))
-
-;; --- per-type amounts ---
-
-(commerce-test
-  "percent-amount"
-  (promo-amount gctx cart (list :percent "TEN" :standard 1000))
-  300)
-
-(commerce-test
-  "fixed-amount-met"
-  (promo-amount gctx cart (list :fixed "FIVER" 5000 500))
-  500)
-
-(commerce-test
-  "fixed-amount-not-met"
-  (promo-amount
-    gctx
-    (list (list "widget" :none 1))
-    (list :fixed "FIVER" 5000 500))
-  0)
-
-(commerce-test
-  "fixed-amount-capped"
-  (promo-amount
-    gctx
-    (list (list "book" :none 1))
-    (list :fixed "BIG" 0 9999))
-  800)
-
-(commerce-test
-  "bundle-amount"
-  (promo-amount gctx cart (list :bundle "B3T" "tea" 3))
-  2000)
-
-(commerce-test
-  "member-amount-guest"
-  (promo-amount gctx cart (list :member "MEM" :standard 1500))
-  0)
-
-(commerce-test
-  "member-amount-member"
-  (promo-amount mctx cart (list :member "MEM" :standard 1500))
-  450)
-
-;; --- relational enumeration: forward ---
-
-(commerce-test
-  "discounto-all-guest"
-  (run*
-    pair
-    (fresh
-      (code amount)
-      (promo-discounto gctx cart ruleset code amount)
-      (== pair (list code amount))))
-  (list
-    (list "TEN" 300)
-    (list "FIVER" 500)
-    (list "B3T" 2000)
-    (list "MEM" 0)))
-
-(commerce-test
-  "applicable-guest"
-  (applicable-promos gctx cart ruleset)
-  (list
-    (list "TEN" 300)
-    (list "FIVER" 500)
-    (list "B3T" 2000)))
-
-(commerce-test
-  "applicable-member"
-  (applicable-promos mctx cart ruleset)
-  (list
-    (list "TEN" 300)
-    (list "FIVER" 500)
-    (list "B3T" 2000)
-    (list "MEM" 450)))
-
-;; --- relational enumeration: backward (the showcase) ---
-
-(commerce-test
-  "code-by-discount-2000"
-  (run* code (promo-applieso gctx cart ruleset code 2000))
-  (list "B3T"))
-
-(commerce-test
-  "code-by-discount-500"
-  (run* code (promo-applieso gctx cart ruleset code 500))
-  (list "FIVER"))
-
-(commerce-test
-  "code-by-discount-none"
-  (run* code (promo-applieso gctx cart ruleset code 9999))
-  (list))
-
-;; --- deterministic helpers ---
-
-(commerce-test
-  "amount-for-ten"
-  (promo-amount-for gctx cart ruleset "TEN")
-  300)
-(commerce-test
-  "amount-for-mem-guest"
-  (promo-amount-for gctx cart ruleset "MEM")
-  0)
-(commerce-test
-  "amount-for-mem-member"
-  (promo-amount-for mctx cart ruleset "MEM")
-  450)
-(commerce-test
-  "amount-for-absent"
-  (promo-amount-for gctx cart ruleset "NOPE")
-  0)

lib/commerce/tests/quote.sx

@@ -1,108 +0,0 @@
-;; lib/commerce/tests/quote.sx — composed priced quote (price+promo+stacking).
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  pcat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "book" 800 :zero-rated)
-      (list "tea" 1000 :reduced))
-    (list)
-    (list)))
-
-(define
-  tax-rules
-  (list
-    (list :uk :standard :guest 2000)
-    (list :uk :reduced :guest 500)
-    (list :uk :zero-rated :guest 0)
-    (list :uk :standard :member 2000)
-    (list :uk :reduced :member 500)
-    (list :uk :zero-rated :member 0)))
-
-(define gctx (make-pricing-context pcat tax-rules :uk :guest))
-(define mctx (make-pricing-context pcat tax-rules :uk :member))
-
-(define
-  cart
-  (list
-    (list "widget" :none 3)
-    (list "book" :none 1)
-    (list "tea" :none 6)))
-
-(define
-  ruleset
-  (list
-    (list :percent "TEN" :standard 1000)
-    (list :percent "TWENTY" :standard 2000)
-    (list :fixed "FIVER" 5000 500)
-    (list :bundle "B3T" "tea" 3)
-    (list :member "MEM" :standard 2500)))
-
-(define
-  exclusions
-  (list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
-
-;; subtotal: 3000 + 800 + 6000 = 9800
-;; tax (gross): widget 600 + tea 300 + book 0 = 900
-;; guest discount: TWENTY 600 + FIVER 500 + B3T 2000 = 3100
-;; guest total: 9800 - 3100 + 900 = 7600
-
-(define gq (cart-quote gctx cart ruleset exclusions))
-
-(commerce-test "quote-subtotal" (quote-subtotal gq) 9800)
-(commerce-test "quote-tax" (quote-tax gq) 900)
-(commerce-test "quote-discount-guest" (quote-discount gq) 3100)
-(commerce-test "quote-total-guest" (quote-total gq) 7600)
-(commerce-test
-  "quote-codes-guest"
-  (quote-codes gq)
-  (list "TWENTY" "FIVER" "B3T"))
-
-(commerce-test "quote-full-guest" gq {:codes (list "TWENTY" "FIVER" "B3T") :subtotal 9800 :discount 3100 :total 7600 :tax 900})
-
-;; member discount: MEM 750 + FIVER 500 + B3T 2000 = 3250
-;; member total: 9800 - 3250 + 900 = 7450
-(define mq (cart-quote mctx cart ruleset exclusions))
-
-(commerce-test "quote-discount-member" (quote-discount mq) 3250)
-(commerce-test "quote-total-member" (quote-total mq) 7450)
-(commerce-test
-  "quote-codes-member"
-  (quote-codes mq)
-  (list "FIVER" "B3T" "MEM"))
-
-;; --- determinism: same inputs, identical quote ---
-
-(commerce-test
-  "quote-deterministic"
-  (=
-    (cart-quote gctx cart ruleset exclusions)
-    (cart-quote gctx cart ruleset exclusions))
-  true)
-
-;; --- no promos: discount 0, total = subtotal + tax ---
-
-(commerce-test
-  "quote-no-promos"
-  (cart-quote gctx cart (list) (list))
-  {:codes (list) :subtotal 9800 :discount 0 :total 10700 :tax 900})
-
-;; --- empty cart ---
-
-(commerce-test
-  "quote-empty"
-  (cart-quote gctx empty-cart ruleset exclusions)
-  {:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
-
-;; --- session convenience ---
-
-(define
-  sess
-  (commerce-add (commerce-session gctx) "widget" :none 3))
-
-(commerce-test
-  "session-quote"
-  (quote-total (session-quote sess ruleset exclusions))
-  3000)

lib/commerce/tests/recon.sx

@@ -1,109 +0,0 @@
-;; lib/commerce/tests/recon.sx — reconciliation as relational ledger queries.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
-
-(define b (persist/mem-backend))
-
-;; OK1 — clean payment
-(define _ok (order-create b "OK1" 1 q1))
-(define _okp (order-pay b "OK1" "ok-ref" 2 1200))
-
-;; OVER1 — double charge under two different refs
-(define _ov (order-create b "OVER1" 1 q1))
-(define _ova (order-pay b "OVER1" "ov-a" 2 1200))
-(define _ovb (order-pay b "OVER1" "ov-b" 3 1200))
-
-;; UNDER1 — short payment
-(define _un (order-create b "UNDER1" 1 q1))
-(define _unp (order-pay b "UNDER1" "un-ref" 2 900))
-
-;; PART1 — paid in full, then partially refunded
-(define _pa (order-create b "PART1" 1 q1))
-(define _pap (order-pay b "PART1" "pa-ref" 2 1200))
-(define _par (order-refund b "PART1" "pa-rf" 3 200))
-
-;; REPLAY1 — webhook fires twice with the same ref (idempotent)
-(define _rp (order-create b "REPLAY1" 1 q1))
-(define _rpa (order-pay b "REPLAY1" "rp-ref" 2 1200))
-(define _rpb (order-pay b "REPLAY1" "rp-ref" 2 1200))
-
-;; PEND1 — created, not yet paid
-(define _pe (order-create b "PEND1" 1 q1))
-
-;; --- summaries ---
-
-(commerce-test "summary-count" (len (ledger-summaries b)) 6)
-(commerce-test
-  "summary-ok1"
-  (order-summary b "order/OK1")
-  (list "order/OK1" 1200 1200 0 1200 :ok))
-(commerce-test
-  "summary-part1"
-  (order-summary b "order/PART1")
-  (list "order/PART1" 1200 1200 200 1000 :underpaid))
-
-;; --- forward status query ---
-
-(commerce-test
-  "status-forward-ok"
-  (run* st (recon-statuso (ledger-summaries b) "order/OK1" st))
-  (list :ok))
-
-;; --- backward status queries (the showcase) ---
-
-(commerce-test
-  "settled"
-  (sort (settled-orders b))
-  (sort (list "order/OK1" "order/REPLAY1")))
-(commerce-test "overpaid" (overpaid-orders b) (list "order/OVER1"))
-(commerce-test
-  "underpaid"
-  (sort (underpaid-orders b))
-  (sort (list "order/UNDER1" "order/PART1")))
-(commerce-test "unpaid" (unpaid-orders b) (list "order/PEND1"))
-(commerce-test
-  "mismatched"
-  (sort (mismatched-orders b))
-  (sort (list "order/OVER1" "order/UNDER1" "order/PART1")))
-
-;; --- backward net-amount query ---
-
-(commerce-test
-  "net-1200"
-  (sort (orders-with-net b 1200))
-  (sort (list "order/OK1" "order/REPLAY1")))
-(commerce-test
-  "net-2400"
-  (orders-with-net b 2400)
-  (list "order/OVER1"))
-(commerce-test
-  "net-900"
-  (orders-with-net b 900)
-  (list "order/UNDER1"))
-
-;; --- discrepancy: +1200 (over) - 300 (under) - 200 (refund) = 700 ---
-
-(commerce-test "discrepancy" (ledger-discrepancy b) 700)
-
-;; --- double-charge guard ---
-
-(commerce-test "double-charge-detected" (order-recon b "OVER1") :overpaid)
-(commerce-test "double-charge-amount" (order-paid b "OVER1") 2400)
-
-;; --- partial refund ---
-
-(commerce-test "partial-refund-net" (order-recon b "PART1") :underpaid)
-(commerce-test
-  "partial-refund-amount"
-  (order-refunded-amount-of (order-events b "PART1"))
-  200)
-
-;; --- webhook replay: same ref twice records once ---
-
-(commerce-test
-  "replay-single-event"
-  (len (order-events b "REPLAY1"))
-  2)
-(commerce-test "replay-paid-once" (order-paid b "REPLAY1") 1200)
-(commerce-test "replay-settled" (order-recon b "REPLAY1") :ok)

lib/commerce/tests/refund.sx

@@ -1,78 +0,0 @@
-;; lib/commerce/tests/refund.sx — refund lifecycle as a flow-on-sx flow.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-;; Builds the (expensive) flow env once; all assertions share it.
-
-(define env (refund-make-env))
-(define b (persist/mem-backend))
-(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
-
-;; a paid, fulfilled order to refund (set up directly via the ledger)
-(define _c (order-create b "O1" 1 q1))
-(define _p (order-pay b "O1" "pay-1" 2 1200))
-(commerce-test "setup-recon-ok" (order-recon b "O1") :ok)
-
-;; --- happy path: request -> approve -> settle ---
-
-(define rid (refund-begin! env b "O1" "rf-1" 10 500))
-
-(commerce-test "begin-waiting-approve" (order-flow-waiting env rid) "approve")
-(commerce-test
-  "begin-not-yet-refunded"
-  (order-refunded-amount-of (order-events b "O1"))
-  0)
-(commerce-test "begin-recon-unchanged" (order-recon b "O1") :ok)
-
-(define a1 (refund-approve! env rid))
-(commerce-test "approve-result" a1 :approved)
-(commerce-test "approve-waiting-settle" (order-flow-waiting env rid) "settle")
-
-(define s1 (refund-settle! env b rid "O1" "rf-1" 11 500))
-(commerce-test "settle-result" s1 :settled)
-(commerce-test "settle-flow-done" (order-flow-status env rid) "done")
-(commerce-test
-  "settle-refunded-amount"
-  (order-refunded-amount-of (order-events b "O1"))
-  500)
-;; net 1200 - 500 = 700 < total 1200 -> underpaid (partial refund)
-(commerce-test "settle-recon-underpaid" (order-recon b "O1") :underpaid)
-
-;; --- idempotent settle: replayed provider callback is a no-op ---
-
-(define s1b (refund-settle! env b rid "O1" "rf-1" 11 500))
-(commerce-test "replay-already-settled" s1b :already-settled)
-(commerce-test
-  "replay-refunded-once"
-  (order-refunded-amount-of (order-events b "O1"))
-  500)
-
-;; --- reject path: approval denied, books untouched ---
-
-(define _c2 (order-create b "O2" 1 q1))
-(define _p2 (order-pay b "O2" "pay-2" 2 1200))
-
-(define rid2 (refund-begin! env b "O2" "rf-2" 20 1200))
-(commerce-test
-  "reject-waiting-approve"
-  (order-flow-waiting env rid2)
-  "approve")
-
-(define j2 (refund-reject! env b "O2" rid2 21 "policy"))
-(commerce-test "reject-result" j2 :rejected)
-(commerce-test "reject-flow-not-waiting" (order-flow-waiting env rid2) nil)
-(commerce-test
-  "reject-no-refund"
-  (order-refunded-amount-of (order-events b "O2"))
-  0)
-(commerce-test "reject-recon-ok" (order-recon b "O2") :ok)
-
-;; settling a rejected/cancelled refund does nothing
-(define s2 (refund-settle! env b rid2 "O2" "rf-2" 22 1200))
-(commerce-test "reject-then-settle-noop" s2 :already-settled)
-(commerce-test
-  "reject-still-no-refund"
-  (order-refunded-amount-of (order-events b "O2"))
-  0)
-
-;; --- distinct flow ids ---
-
-(commerce-test "distinct-refund-ids" (not (= rid rid2)) true)

lib/commerce/tests/stack.sx

@@ -1,127 +0,0 @@
-;; lib/commerce/tests/stack.sx — stacking precedence, exclusivity, best price.
-;; Uses (commerce-test name got expected) provided by conformance.sh.
-
-(define
-  pcat
-  (make-catalog
-    (list
-      (list "widget" 1000 :standard)
-      (list "book" 800 :zero-rated)
-      (list "tea" 1000 :reduced))
-    (list)
-    (list)))
-
-(define gctx (make-pricing-context pcat (list) :uk :guest))
-(define mctx (make-pricing-context pcat (list) :uk :member))
-
-(define
-  cart
-  (list
-    (list "widget" :none 3)
-    (list "book" :none 1)
-    (list "tea" :none 6)))
-
-(define
-  ruleset
-  (list
-    (list :percent "TEN" :standard 1000)
-    (list :percent "TWENTY" :standard 2000)
-    (list :fixed "FIVER" 5000 500)
-    (list :bundle "B3T" "tea" 3)
-    (list :member "MEM" :standard 2500)))
-
-;; The three standard-class discounts are mutually exclusive.
-(define
-  exclusions
-  (list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
-
-;; --- exclusivity predicates ---
-
-(commerce-test
-  "excluded-pair-direct"
-  (excluded-pair? exclusions "TEN" "TWENTY")
-  true)
-(commerce-test
-  "excluded-pair-symmetric"
-  (excluded-pair? exclusions "TWENTY" "TEN")
-  true)
-(commerce-test
-  "excluded-pair-none"
-  (excluded-pair? exclusions "TEN" "FIVER")
-  false)
-(commerce-test
-  "compatible-yes"
-  (compatible? exclusions (list "FIVER" "B3T" "TWENTY"))
-  true)
-(commerce-test
-  "compatible-no"
-  (compatible? exclusions (list "TEN" "TWENTY" "B3T"))
-  false)
-
-;; --- powerset + valid stackings ---
-
-(commerce-test
-  "powerset-size"
-  (len (powerset (list 1 2 3 4)))
-  16)
-
-(define gappl (applicable-promos gctx cart ruleset))
-
-(commerce-test "applicable-guest-count" (len gappl) 4)
-
-;; 16 subsets minus the 4 containing both TEN and TWENTY = 12 legal.
-(commerce-test
-  "valid-stackings-count"
-  (len (valid-stackings exclusions gappl))
-  12)
-
-(commerce-test
-  "stacking-total"
-  (stacking-total (list (list "TWENTY" 600) (list "B3T" 2000)))
-  2600)
-
-;; --- best price (deterministic selection) ---
-
-(commerce-test
-  "best-discount-guest"
-  (best-promo-discount gctx cart ruleset exclusions)
-  3100)
-(commerce-test
-  "best-codes-guest"
-  (best-promo-codes gctx cart ruleset exclusions)
-  (list "TWENTY" "FIVER" "B3T"))
-
-;; exclusivity holds: the cheaper conflicting code is dropped.
-(commerce-test
-  "best-excludes-ten"
-  (some
-    (fn (c) (= c "TEN"))
-    (best-promo-codes gctx cart ruleset exclusions))
-  false)
-
-;; --- member vs guest ---
-
-(commerce-test
-  "best-discount-member"
-  (best-promo-discount mctx cart ruleset exclusions)
-  3250)
-(commerce-test
-  "best-codes-member"
-  (best-promo-codes mctx cart ruleset exclusions)
-  (list "FIVER" "B3T" "MEM"))
-
-;; --- best price backward query (the showcase) ---
-
-(commerce-test
-  "stacking-by-total-backward"
-  (run*
-    codes
-    (stacking-by-totalo (valid-stackings exclusions gappl) codes 3100))
-  (list (list "TWENTY" "FIVER" "B3T")))
-
-;; --- edge: no applicable promos ---
-
-(commerce-test
-  "best-empty"
-  (best-promo-discount gctx empty-cart ruleset exclusions)
-  0)