host: hand off the native SX-island editor (browser-capable session)

The editor is the interactivity layer — it belongs on the --http island pipeline
(SSRs + hydrates islands), not the http-listen host, and needs browser/Playwright
iteration which this worktree lacks. plans/blog-editor-island.md is the handoff:
goal, architecture (docs-side island -> host /new), the live host contract
(form-urlencoded title/sx_content/status -> 303), the sx_content markup to emit
(standard tags, NOT legacy ~kg-* cards), island authoring gotchas, and pointers.
Host side is ready (ingest proven; CORS on request). Phase 5.5 marked handed off.

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

docker-compose.dev-sx-host.yml

@@ -0,0 +1,44 @@
+# 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
+      OCAMLRUNPARAM: "b"
+    volumes:
+      # SX source (hot-reload on container restart)
+      - ./spec:/app/spec:ro
+      - ./lib:/app/lib:ro
+      - ./web:/app/web: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/sx_server.ml

@@ -745,8 +745,15 @@ 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 (Unix.inet_addr_loopback, port));
+        (Unix.ADDR_INET (bind_addr, port));
       Unix.listen sock 64;
       (* SX runtime is shared across threads — serialize handler calls. *)
       let mtx = Mutex.create () in
@@ -807,7 +814,15 @@ let setup_evaluator_bridge env =
              Hashtbl.replace req "body" (String body);
              Mutex.lock mtx;
              let resp =
-               (try Sx_runtime.sx_call handler [Dict req]
+               (* 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. *)
+               (try
+                  let st = Sx_ref.continue_with_call handler
+                             (List [Dict req]) (Env (Sx_types.make_env ()))
+                             (List [Dict req]) (List []) in
+                  cek_run_with_io st
                 with e -> Mutex.unlock mtx; raise e) in
              Mutex.unlock mtx;
              let getk k = match resp with
@@ -4854,6 +4869,14 @@ 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)"))));
     send "(ready)";
     (* Main command loop *)
     try

lib/content/api.sx

@@ -25,8 +25,13 @@
 (define content/append doc-append)
 (define content/blocks doc-blocks)
 (define content/count doc-count)
-(define content/find doc-find)
-(define content/has? doc-has?)
+;; find / has? are TREE-WIDE by id (descend into sections) — so the facade reads
+;; back any block content/edit can update or delete. content/find-top / has-top?
+;; keep the top-level-only lookup for callers that mean the ordered sequence.
+(define content/find doc-find-deep)
+(define content/has? doc-has-deep?)
+(define content/find-top doc-find)
+(define content/has-top? doc-has?)
 (define content/ids doc-ids)
 (define content/types doc-types)
 

lib/content/doc.sx

@@ -5,14 +5,19 @@
 ;; and returns a NEW document — the input is never mutated, so any version is the
 ;; head of an op stream (replay-friendly for persist + CRDT merge).
 ;;
-;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
-;; ergonomic API; they default nil and do not affect block operations.
+;; By-id ops (update/delete) and by-id lookup (doc-find-deep/doc-has-deep?) are
+;; TREE-WIDE: they descend into any block carrying a `children` list (i.e.
+;; sections), since ids are unique across the tree. This keeps the persist
+;; op-log, content/edit and content/find correct for nested documents.
+;; insert/move are positional and act at the top level.
+;;
+;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx.
 ;;
 ;; Op shapes (data, not objects — they are the persist event payload):
-;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend
-;;   {:op "update" :id <id> :field <name> :value <v>}
-;;   {:op "move"   :id <id> :index <n>}
-;;   {:op "delete" :id <id>}
+;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend (top level)
+;;   {:op "update" :id <id> :field <name> :value <v>}   ; tree-wide by id
+;;   {:op "move"   :id <id> :index <n>}                 ; top level
+;;   {:op "delete" :id <id>}                            ; tree-wide by id
 
 (define
   content-bootstrap-doc!
@@ -76,17 +81,58 @@
           (first blocks)
           (ct-insert-at (rest blocks) (- i 1) x))))))
 
+;; tree-wide remove by id: drop matches at this level, recurse into children
+;; (blocks carrying a `children` list, i.e. sections).
 (define
   ct-remove-id
   (fn
     (blocks id)
-    (filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
+    (map
+      (fn
+        (b)
+        (let
+          ((ch (st-iv-get b "children")))
+          (if (list? ch) (st-iv-set! b "children" (ct-remove-id ch id)) b)))
+      (filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))
 
+;; tree-wide replace by id: apply f to the match wherever it sits in the tree.
 (define
   ct-replace-id
   (fn
     (blocks id f)
-    (map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
+    (map
+      (fn
+        (b)
+        (if
+          (= (blk-id b) id)
+          (f b)
+          (let
+            ((ch (st-iv-get b "children")))
+            (if
+              (list? ch)
+              (st-iv-set! b "children" (ct-replace-id ch id f))
+              b))))
+      blocks)))
+
+;; tree-wide find by id: first block matching id anywhere in the tree, or nil.
+;; Descends into any `children` list, mirroring ct-replace-id/ct-remove-id.
+(define
+  ct-find-id
+  (fn
+    (blocks id)
+    (if
+      (= (len blocks) 0)
+      nil
+      (let
+        ((b (first blocks)))
+        (if
+          (= (blk-id b) id)
+          b
+          (let
+            ((ch (st-iv-get b "children")))
+            (let
+              ((nested (if (list? ch) (ct-find-id ch id) nil)))
+              (if (= nested nil) (ct-find-id (rest blocks) id) nested))))))))
 
 ;; ── query ──
 (define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
@@ -103,6 +149,14 @@
   doc-has?
   (fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
 
+;; tree-wide lookup by id — reads a nested block by the same id content/edit can
+;; update/delete (no section.sx dependency; uses the generic children descent).
+(define doc-find-deep (fn (doc id) (ct-find-id (doc-blocks doc) id)))
+
+(define
+  doc-has-deep?
+  (fn (doc id) (if (= (doc-find-deep doc id) nil) false true)))
+
 ;; ── structural edits (each returns a new document) ──
 (define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
 

lib/content/find-replace.sx

@@ -1,10 +1,17 @@
-;; content-on-sx — global find/replace across text-bearing blocks.
+;; content-on-sx — global find/replace across every text-bearing field.
 ;;
-;; Replaces every occurrence of `from` with `to` in the text field of text /
-;; heading / code / quote blocks, tree-wide (via the transform layer). For
-;; renaming a term throughout a document. Immutable; case-sensitive.
+;; Replaces every occurrence of `from` with `to` in the text-bearing fields of
+;; a document, tree-wide (via the transform layer):
+;;   - the `text` of text / heading / code / quote / callout blocks
+;;   - the `alt` of image blocks
+;;   - each item of list blocks
+;;   - every header and cell of table blocks
+;; This is exactly the set asText / stats / summary draw prose from, so a rename
+;; via content/find-replace and a word count over asText stay consistent.
+;; Immutable; case-sensitive.
 ;;
-;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks).
+;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks),
+;; table.sx (CtTable ivars).
 
 (define
   fr-in?
@@ -15,17 +22,54 @@
       ((= (first xs) x) true)
       (else (fr-in? x (rest xs))))))
 
+(define fr-rep (fn (s from to) (replace (str s) from to)))
+
+;; Blocks whose prose content find/replace rewrites (matches asText's set).
 (define
   fr-has-text?
-  (fn (b) (fr-in? (blk-type b) (list "text" "heading" "code" "quote"))))
+  (fn
+    (b)
+    (fr-in?
+      (blk-type b)
+      (list "text" "heading" "code" "quote" "callout" "image" "list" "table"))))
+
+;; Per-type field rewrite. Each branch returns a new (copy-on-write) block.
+(define
+  fr-rewrite
+  (fn
+    (b from to)
+    (let
+      ((t (blk-type b)))
+      (cond
+        ((= t "image")
+          (blk-set b "alt" (fr-rep (blk-get b "alt") from to)))
+        ((= t "list")
+          (let
+            ((items (blk-get b "items")))
+            (if
+              (list? items)
+              (blk-set b "items" (map (fn (it) (fr-rep it from to)) items))
+              b)))
+        ((= t "table")
+          (let
+            ((hs (blk-get b "headers")) (rs (blk-get b "rows")))
+            (let
+              ((b1 (if (list? hs) (blk-set b "headers" (map (fn (h) (fr-rep h from to)) hs)) b)))
+              (if
+                (list? rs)
+                (blk-set
+                  b1
+                  "rows"
+                  (map
+                    (fn
+                      (r)
+                      (if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
+                    rs))
+                b1))))
+        (else (blk-set b "text" (fr-rep (blk-get b "text") from to)))))))
 
 (define
   content/find-replace
   (fn
     (doc from to)
-    (content/map-blocks
-      doc
-      fr-has-text?
-      (fn
-        (b)
-        (blk-set b "text" (replace (str (blk-get b "text")) from to))))))
+    (content/map-blocks doc fr-has-text? (fn (b) (fr-rewrite b from to)))))

lib/content/query.sx

@@ -1,10 +1,10 @@
 ;; content-on-sx — block query + table of contents.
 ;;
 ;; Collect blocks across the whole tree (descending into sections) by predicate
-;; or type, and derive a table of contents from headings. Tree detection is
-;; inline (class + st-iv-get) so this needs no section.sx.
+;; or type, search them by prose, and derive a table of contents from headings.
+;; Tree detection is inline (class + st-iv-get) so this needs no section.sx.
 ;;
-;; Requires (loaded by harness): block.sx, doc.sx.
+;; Requires (loaded by harness): block.sx, doc.sx, text.sx (asText for search).
 
 (define
   qry-section?
@@ -45,6 +45,30 @@
   content/select-ids
   (fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
 
+;; Blocks (tree-wide, excluding section containers) whose own prose contains
+;; `term`. "Prose" is (asText b), so search covers exactly what every block
+;; exposes as text — text/heading/code/quote/callout text, image alt, list
+;; items, table headers+cells — with no separate field list to drift from
+;; asText / find-replace / stats. Case-sensitive substring match.
+(define
+  content/search-text
+  (fn
+    (doc term)
+    (content/select
+      doc
+      (fn
+        (b)
+        (and
+          (not (qry-section? b))
+          (>= (index-of (asText b) term) 0))))))
+
+;; Same search, returning matching block ids in document order.
+(define
+  content/search-text-ids
+  (fn
+    (doc term)
+    (map (fn (b) (blk-id b)) (content/search-text doc term))))
+
 ;; table of contents: {:id :level :text} for every heading, in document order.
 (define
   content/headings

lib/content/scoreboard.json

@@ -3,7 +3,7 @@
     "block": {"pass": 38, "fail": 0},
     "doc": {"pass": 40, "fail": 0},
     "render": {"pass": 42, "fail": 0},
-    "api": {"pass": 26, "fail": 0},
+    "api": {"pass": 32, "fail": 0},
     "meta": {"pass": 27, "fail": 0},
     "page": {"pass": 7, "fail": 0},
     "page-full": {"pass": 4, "fail": 0},
@@ -14,14 +14,14 @@
     "tree-edit": {"pass": 17, "fail": 0},
     "move": {"pass": 11, "fail": 0},
     "clone": {"pass": 10, "fail": 0},
-    "query": {"pass": 13, "fail": 0},
+    "query": {"pass": 20, "fail": 0},
     "toc": {"pass": 8, "fail": 0},
     "anchor": {"pass": 6, "fail": 0},
     "outline": {"pass": 14, "fail": 0},
     "flatten": {"pass": 10, "fail": 0},
     "transform": {"pass": 12, "fail": 0},
     "normalize": {"pass": 11, "fail": 0},
-    "find-replace": {"pass": 10, "fail": 0},
+    "find-replace": {"pass": 16, "fail": 0},
     "stats": {"pass": 17, "fail": 0},
     "summary": {"pass": 14, "fail": 0},
     "index": {"pass": 13, "fail": 0},
@@ -31,7 +31,7 @@
     "data": {"pass": 25, "fail": 0},
     "wire": {"pass": 11, "fail": 0},
     "validate": {"pass": 23, "fail": 0},
-    "store": {"pass": 33, "fail": 0},
+    "store": {"pass": 46, "fail": 0},
     "snapshot": {"pass": 20, "fail": 0},
     "crdt": {"pass": 34, "fail": 0},
     "crdt-tree": {"pass": 21, "fail": 0},
@@ -42,7 +42,7 @@
     "md-doc": {"pass": 12, "fail": 0},
     "fed": {"pass": 20, "fail": 0}
   },
-  "total_pass": 746,
+  "total_pass": 778,
   "total_fail": 0,
-  "total": 746
+  "total": 778
 }

lib/content/scoreboard.md

@@ -7,7 +7,7 @@ _Generated by `lib/content/conformance.sh`_
 | block | 38 | 0 | 38 |
 | doc | 40 | 0 | 40 |
 | render | 42 | 0 | 42 |
-| api | 26 | 0 | 26 |
+| api | 32 | 0 | 32 |
 | meta | 27 | 0 | 27 |
 | page | 7 | 0 | 7 |
 | page-full | 4 | 0 | 4 |
@@ -18,14 +18,14 @@ _Generated by `lib/content/conformance.sh`_
 | tree-edit | 17 | 0 | 17 |
 | move | 11 | 0 | 11 |
 | clone | 10 | 0 | 10 |
-| query | 13 | 0 | 13 |
+| query | 20 | 0 | 20 |
 | toc | 8 | 0 | 8 |
 | anchor | 6 | 0 | 6 |
 | outline | 14 | 0 | 14 |
 | flatten | 10 | 0 | 10 |
 | transform | 12 | 0 | 12 |
 | normalize | 11 | 0 | 11 |
-| find-replace | 10 | 0 | 10 |
+| find-replace | 16 | 0 | 16 |
 | stats | 17 | 0 | 17 |
 | summary | 14 | 0 | 14 |
 | index | 13 | 0 | 13 |
@@ -35,7 +35,7 @@ _Generated by `lib/content/conformance.sh`_
 | data | 25 | 0 | 25 |
 | wire | 11 | 0 | 11 |
 | validate | 23 | 0 | 23 |
-| store | 33 | 0 | 33 |
+| store | 46 | 0 | 46 |
 | snapshot | 20 | 0 | 20 |
 | crdt | 34 | 0 | 34 |
 | crdt-tree | 21 | 0 | 21 |
@@ -45,4 +45,4 @@ _Generated by `lib/content/conformance.sh`_
 | md-import | 38 | 0 | 38 |
 | md-doc | 12 | 0 | 12 |
 | fed | 20 | 0 | 20 |
-| **Total** | **746** | **0** | **746** |
+| **Total** | **778** | **0** | **778** |

lib/content/store.sx

@@ -5,9 +5,10 @@
 ;; replay of its op stream up to a sequence number; the materialised doc is a
 ;; cache, never primary state.
 ;;
-;; Requires (loaded by the harness): block.sx, doc.sx, and persist
-;; (event/backend/log/kv/api). The persist backend `b` is opened by the caller
-;; via (persist/open) and injected — content knows nothing about which backend.
+;; Requires (loaded by the harness): block.sx, doc.sx, section.sx (doc-deep-find
+;; + doc-tree-ids, for the tree-wide diff), plus persist (event/backend/log/kv/
+;; api). The persist backend `b` is opened by the caller via (persist/open) and
+;; injected — content knows nothing about which backend.
 
 (define content/-stream (fn (doc-id) (str "content:" doc-id)))
 
@@ -69,11 +70,18 @@
   (fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
 
 ;; ── diff between two materialised document versions ──
-;; Returns {:added (ids) :removed (ids) :changed (ids)} where changed = ids
-;; present in both whose block content differs.
-(define
-  content/-missing?
-  (fn (doc id) (= (ct-index-of (doc-blocks doc) id) -1)))
+;; Tree-wide: ids are enumerated across the whole block tree (descending into
+;; sections), so nested-block adds/removes/changes are detected, not just
+;; top-level ones. Returns {:added :removed :changed} (lists of ids):
+;;   :added   — ids present (anywhere) in `new` but not in `old`
+;;   :removed — ids present (anywhere) in `old` but not in `new`
+;;   :changed — content blocks present in both whose block value differs
+;; Section containers never appear in :changed (they hold no own content — a
+;; child change surfaces as that child's own entry); a whole section appearing
+;; or disappearing shows up in :added / :removed by its id.
+(define content/-all-ids (fn (doc) (doc-tree-ids doc)))
+
+(define content/-missing? (fn (doc id) (= (doc-deep-find doc id) nil)))
 
 (define
   content/-changed
@@ -83,15 +91,16 @@
       (fn
         (id)
         (let
-          ((bo (doc-find old id)) (bn (doc-find new id)))
+          ((bo (doc-deep-find old id)) (bn (doc-deep-find new id)))
           (cond
             ((= bo nil) false)
             ((= bn nil) false)
+            ((= (blk-type bo) "section") false)
             ((= bo bn) false)
             (else true))))
-      (doc-ids old))))
+      (content/-all-ids old))))
 
-(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (doc-ids old)) :added (filter (fn (id) (content/-missing? old id)) (doc-ids new))}))
+(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (content/-all-ids old)) :added (filter (fn (id) (content/-missing? old id)) (content/-all-ids new))}))
 
 ;; convenience: diff two persisted versions by seq.
 (define

lib/content/tests/api.sx

@@ -97,3 +97,37 @@
   "render original unchanged"
   (content/render d1 "html")
   "<h1>Hi</h1><p>World</p>")
+
+;; ── facade find/has? are TREE-WIDE (reach into sections); find-top/has-top?
+;; keep the top-level-only lookup. This makes the read-by-id surface consistent
+;; with content/edit, whose update/delete are already tree-wide. ──
+(content-bootstrap-section!)
+(define
+  nd
+  (content/append
+    (content/empty "nested")
+    (mk-section
+      "sec"
+      (list (content/block "text" "inner" (list (list "text" "deep")))))))
+(content-test
+  "find nested (deep)"
+  (blk-id (content/find nd "inner"))
+  "inner")
+(content-test "has? nested (deep)" (content/has? nd "inner") true)
+(content-test "find-top misses nested" (content/find-top nd "inner") nil)
+(content-test "has-top? misses nested" (content/has-top? nd "inner") false)
+(content-test
+  "find-top sees top-level"
+  (blk-id (content/find-top nd "sec"))
+  "sec")
+;; a nested block updated by id via content/edit is now readable by id via
+;; content/find (was impossible when find was top-level-only).
+(content-test
+  "edit-then-find nested round-trip"
+  (str
+    (blk-send
+      (content/find
+        (content/edit nd (content/update "inner" "text" "edited"))
+        "inner")
+      "text"))
+  "edited")

lib/content/tests/find-replace.sx

@@ -1,8 +1,10 @@
-;; Extension — global find/replace across text-bearing blocks.
+;; Extension — global find/replace across every text-bearing field.
 
 (st-bootstrap-classes!)
 (content/bootstrap!)
 (content-bootstrap-section!)
+(content-bootstrap-callout!)
+(content-bootstrap-table!)
 
 (define
   d
@@ -30,11 +32,12 @@
   (str (blk-send (doc-deep-find r "n") "text"))
   "nested Bar")
 
-;; ── does NOT touch image alt/src (not a text field) ──
+;; ── image alt IS a text field (asText ^ alt), so it is rewritten ──
 (content-test
-  "image alt untouched"
+  "image alt replaced"
   (str (blk-send (doc-deep-find r "img") "alt"))
-  "Foo alt")
+  "Bar alt")
+;; ── but src is a URL, not prose, so it stays put ──
 (content-test
   "image src untouched"
   (str (blk-send (doc-deep-find r "img") "src"))
@@ -76,6 +79,68 @@
   (str (blk-send (doc-find r2 "q") "text"))
   "new saying")
 
+;; ── callout text is covered (consistency with asText/stats/summary) ──
+(content-test
+  "replace callout text"
+  (str
+    (blk-send
+      (doc-find
+        (content/find-replace
+          (doc-append (doc-empty "d") (mk-callout "co" "note" "Foo here"))
+          "Foo"
+          "Bar")
+        "co")
+      "text"))
+  "Bar here")
+(content-test
+  "callout kind untouched by text replace"
+  (str
+    (blk-send
+      (doc-find
+        (content/find-replace
+          (doc-append (doc-empty "d") (mk-callout "co" "note" "x"))
+          "note"
+          "X")
+        "co")
+      "kind"))
+  "note")
+
+;; ── list items are rewritten (asText folds items) ──
+(define
+  rl
+  (content/find-replace
+    (doc-append
+      (doc-empty "d")
+      (mk-list "l" false (list "Foo one" "two Foo")))
+    "Foo"
+    "Bar"))
+(content-test
+  "replace first list item"
+  (str (first (blk-send (doc-find rl "l") "items")))
+  "Bar one")
+(content-test
+  "replace second list item"
+  (str (first (rest (blk-send (doc-find rl "l") "items"))))
+  "two Bar")
+
+;; ── table headers + cells are rewritten (asText folds rows) ──
+(define
+  rt
+  (content/find-replace
+    (doc-append
+      (doc-empty "d")
+      (mk-table "t" (list "Foo head") (list (list "a Foo" "b"))))
+    "Foo"
+    "Bar"))
+(content-test
+  "replace table header"
+  (str (first (table-headers (doc-find rt "t"))))
+  "Bar head")
+(content-test
+  "replace table cell"
+  (str (first (first (table-rows (doc-find rt "t")))))
+  "a Bar")
+
 ;; ── no match → unchanged render ──
 (content-test
   "no match"

lib/content/tests/query.sx

@@ -1,8 +1,11 @@
-;; Extension — block query + table of contents.
+;; Extension — block query + table of contents + prose search.
 
 (st-bootstrap-classes!)
 (content/bootstrap!)
+(content-bootstrap-text!)
 (content-bootstrap-section!)
+(content-bootstrap-table!)
+(content-bootstrap-callout!)
 
 (define
   d
@@ -87,3 +90,49 @@
   "deep toc level"
   (get (first (content/headings deep)) :level)
   3)
+
+;; ── prose search (content/search-text) ──
+;; "cat" appears in text, image alt, a list item, a table cell, and a callout
+;; — every text-bearing field — so search must find all five via asText.
+(define
+  sd
+  (doc-append
+    (doc-append
+      (doc-append
+        (doc-append
+          (doc-append
+            (doc-empty "sd")
+            (mk-heading "sh" 1 "Welcome aboard"))
+          (mk-text "st" "the cat sat"))
+        (mk-image "si" "/x.png" "a cat photo"))
+      (mk-list "sl" false (list "first cat" "second dog")))
+    (mk-section
+      "sec"
+      (list
+        (mk-table "stb" (list "Animal") (list (list "cat") (list "fish")))
+        (mk-callout "sc" "note" "beware of cat")))))
+
+(content-test
+  "search across every text-bearing field"
+  (content/search-text-ids sd "cat")
+  (list "st" "si" "sl" "stb" "sc"))
+(content-test "search count" (len (content/search-text sd "cat")) 5)
+(content-test
+  "search heading text"
+  (content/search-text-ids sd "Welcome")
+  (list "sh"))
+(content-test
+  "search list item only"
+  (content/search-text-ids sd "dog")
+  (list "sl"))
+(content-test "search no match" (content/search-text-ids sd "zzz") (list))
+;; section containers are excluded — a term living only inside a section's
+;; children returns the child, never the section wrapper.
+(content-test
+  "search excludes section wrapper"
+  (content/search-text-ids sd "fish")
+  (list "stb"))
+(content-test
+  "search returns block objects"
+  (blk-id (first (content/search-text sd "Welcome")))
+  "sh")

lib/content/tests/store.sx

@@ -151,3 +151,58 @@
   "op-log media type"
   (blk-type (doc-find (content/head B3 "rich") "v"))
   "media")
+
+;; ── op-log update/delete reach NESTED blocks (tree-wide by id) ──
+(content-bootstrap-section!)
+(define B4 (persist/open))
+(content/commit!
+  B4
+  "nest"
+  (op-insert (mk-section "sec" (list (mk-text "n" "orig"))) nil)
+  1)
+(content/commit! B4 "nest" (op-update "n" "text" "edited") 2)
+(content-test
+  "op-log nested update"
+  (str (blk-send (doc-deep-find (content/head B4 "nest") "n") "text"))
+  "edited")
+(content-test
+  "op-log nested update tree intact"
+  (doc-tree-ids (content/head B4 "nest"))
+  (list "sec" "n"))
+(content/commit! B4 "nest" (op-delete "n") 3)
+(content-test
+  "op-log nested delete"
+  (doc-tree-ids (content/head B4 "nest"))
+  (list "sec"))
+(content-test
+  "op-log nested delete via content/at seq2"
+  (doc-tree-ids (content/at B4 "nest" 2))
+  (list "sec" "n"))
+
+;; ── diff is TREE-WIDE: nested-block add/change/remove are detected, and
+;; section containers never appear in :changed (a top-level-only diff would miss
+;; "n" entirely and instead flag the section). ──
+(define dn01 (content/diff-versions B4 "nest" 0 1))
+(content-test
+  "diff nested added (section + child)"
+  (get dn01 :added)
+  (list "sec" "n"))
+(content-test "diff nested added removed empty" (get dn01 :removed) (list))
+(content-test "diff nested added changed empty" (get dn01 :changed) (list))
+
+(define dn12 (content/diff-versions B4 "nest" 1 2))
+(content-test
+  "diff nested changed child only"
+  (get dn12 :changed)
+  (list "n"))
+(content-test "diff nested changed no add" (get dn12 :added) (list))
+(content-test "diff nested changed no remove" (get dn12 :removed) (list))
+
+(define dn23 (content/diff-versions B4 "nest" 2 3))
+(content-test "diff nested removed child" (get dn23 :removed) (list "n"))
+(content-test "diff nested removed no change" (get dn23 :changed) (list))
+
+(content-test
+  "diff nested no-op"
+  (get (content/diff-versions B4 "nest" 1 1) :changed)
+  (list))

lib/dream/README.md

@@ -0,0 +1,79 @@
+# dream-on-sx
+
+OCaml's [Dream](https://aantron.github.io/dream/) web framework, reimplemented in
+**plain SX** on the CEK evaluator. Dream is the cleanest middleware-shaped HTTP
+framework in any language, and it maps onto SX with almost no impedance:
+
+| Dream | SX |
+|-------|-----|
+| `handler = request -> response promise` | `(fn (req) … (perform …))` |
+| `middleware = handler -> handler` | `(fn (next) (fn (req) …))` |
+| `m1 @@ m2 @@ handler` | `(m1 (m2 handler))` — left fold |
+| `Dream.run handler` | `(dream-run handler)` → `(perform (:http/listen …))` |
+
+There are five types — **request, response, route**, and (as plain functions)
+**handler** and **middleware**. Everything else is a function over them.
+
+## Quickstart
+
+```lisp
+(dream-run
+  (dream-make-app
+    (list
+      (dream-get "/" (fn (req) (dream-html "<h1>Hello, World!</h1>")))
+      (dream-get "/hello/:name"
+        (fn (req) (dream-text (str "Hi, " (dream-param req "name"))))))))
+```
+
+`dream-make-app` wraps the router in the default stack (error catch + content-type).
+`dream-run` installs the root handler on the existing SX HTTP server — it does **not**
+open its own socket.
+
+## Public surface
+
+- **types** — `dream-request`/`dream-response`/`dream-route`, accessors
+  (`dream-method`/`-path`/`-body`/`-header`/`-query-param`/`-param`), smart
+  constructors (`dream-html`/`-text`/`-json`/`-empty`/`-not-found`/`-redirect`),
+  convenience (`dream-queries`, `*-or` defaults, `dream-accepts?`/`dream-wants-json?`).
+- **router** — `dream-get`/`-post`/`-put`/`-delete`/`-patch`/`-head`/`-options`/`-any`,
+  `dream-router`, `dream-scope` (prefix + middleware), `:name` params + `**` catch-all,
+  405 + `Allow`, automatic HEAD.
+- **middleware** — `dream-pipeline`, `dream-no-middleware`, `dream-logger`,
+  `dream-content-type`, `dream-set-header`, `dream-tap-request`.
+- **session** — `dream-sessions` / `dream-sessions-signed`, `dream-session-field` /
+  `dream-set-session-field` / `dream-session-all` / `dream-invalidate-session`; cookie
+  helpers (`dream-cookie`, `dream-set-cookie`, `dream-cookie-sign`/`-unsign`).
+- **flash** — `dream-flash`, `dream-add-flash-message`, `dream-flash-messages`.
+- **form** — `dream-form` (Ok/Err), `dream-form-fields`, `dream-multipart`, CSRF
+  (`dream-csrf` / `dream-csrf-protect` / `dream-csrf-token` / `dream-csrf-tag`).
+- **websocket** — `dream-websocket`, `dream-send`/`-receive`/`-close`/`-broadcast`.
+- **static** — `dream-static` (mime, ETags, 304, ranges, traversal guard).
+- **error** — `dream-catch`, `dream-status-text`/`-line`, `dream-status-page`.
+- **cors** — `dream-cors`, `dream-cors-origin`, `dream-cors-with`.
+- **json** — `dream-json-encode`/`-parse`, `dream-json-value`, `dream-json-body`.
+- **run / api** — `dream-run`/`-port`/`-opts`, `dream-app`, `dream-make-app`,
+  `dream-serve`.
+
+## Testing story
+
+Every effectful concern is **dependency-injected**, so the whole framework is testable
+without a running host:
+
+- sessions take a backend `(fn (op) …)` — `dream-memory-sessions` for tests,
+  `dream-perform-sessions` in production;
+- static files take an fs — `dream-memory-fs` vs `dream-static-perform-fs`;
+- websockets take an io — `dream-mock-ws` vs `dream-ws-perform-io`;
+- `dream-run` takes a listen transport (`dream-run-with`).
+
+Run the suite: `bash lib/dream/conformance.sh` (367 tests, 14 suites).
+
+## Notes & caveats
+
+- Headers are dicts with **lowercased string keys** (in SX keywords *are* strings, so
+  `:content-type` == `"content-type"`).
+- Outgoing cookies accumulate in a `:set-cookies` list on the response so multiple
+  `Set-Cookie` headers don't collide.
+- The CSRF/cookie/ETag signing uses a pure-SX keyed hash — **not cryptographic**.
+  Production should inject a host HMAC (`dream-csrf-with`, and the signed-session
+  secret path).
+- JSON and multipart are in-memory (not streaming).

lib/dream/api.sx

@@ -0,0 +1,33 @@
+;; lib/dream/api.sx — Dream-on-SX public facade.
+;; Loaded last; bundles the modules into a batteries-included surface. The full
+;; public API is the `dream-*` functions across types/router/middleware/session/
+;; flash/form/websocket/static/error/cors/json/run; this file adds convenience
+;; app builders. Depends on all other dream modules.
+
+(define dream-version "0.1.0")
+
+;; standard middleware stack (pure — no IO): error catch outermost, then
+;; content-type sniffing. Logger is opt-in since it performs host IO.
+(define
+  dream-defaults
+  (fn
+    (handler)
+    (dream-pipeline (list dream-catch dream-content-type) handler)))
+
+;; build a complete app handler from a route list with the default stack
+(define
+  dream-make-app
+  (fn (routes) (dream-defaults (dream-router routes))))
+
+;; build an app and wrap it with extra middleware (outermost first)
+(define
+  dream-make-app-with
+  (fn
+    (middlewares routes)
+    (dream-pipeline middlewares (dream-make-app routes))))
+
+;; one-call serve: routes + opts -> installed on the host
+(define
+  dream-serve
+  (fn (routes opts) (dream-run-opts (dream-make-app routes) opts)))
+(define dream-serve-port (fn (routes port) (dream-serve routes {:port port})))

lib/dream/auth.sx

@@ -0,0 +1,172 @@
+;; lib/dream/auth.sx — Dream-on-SX authentication helpers.
+;; HTTP Basic auth (with a pure-SX base64 codec) and Bearer-token guards.
+;; Depends on types.sx.
+
+;; ── base64 (pure SX; arithmetic, no bitwise) ───────────────────────
+(define
+  dr/b64-alpha
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+(define dr/b64-char (fn (n) (char-at dr/b64-alpha n)))
+(define dr/b64-index (fn (c) (index-of dr/b64-alpha c)))
+
+(define
+  dr/b64-encode-loop
+  (fn
+    (s i n acc)
+    (if
+      (>= i n)
+      acc
+      (let
+        ((b0 (char-code (char-at s i))) (rem (- n i)))
+        (cond
+          ((>= rem 3)
+            (let
+              ((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256) (char-code (char-at s (+ i 2))))))
+              (dr/b64-encode-loop
+                s
+                (+ i 3)
+                n
+                (str
+                  acc
+                  (dr/b64-char (mod (quotient triple 262144) 64))
+                  (dr/b64-char (mod (quotient triple 4096) 64))
+                  (dr/b64-char (mod (quotient triple 64) 64))
+                  (dr/b64-char (mod triple 64))))))
+          ((= rem 2)
+            (let
+              ((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256))))
+              (str
+                acc
+                (dr/b64-char (mod (quotient triple 262144) 64))
+                (dr/b64-char (mod (quotient triple 4096) 64))
+                (dr/b64-char (mod (quotient triple 64) 64))
+                "=")))
+          (else
+            (let
+              ((triple (* b0 65536)))
+              (str
+                acc
+                (dr/b64-char (mod (quotient triple 262144) 64))
+                (dr/b64-char (mod (quotient triple 4096) 64))
+                "=="))))))))
+
+(define
+  dream-base64-encode
+  (fn (s) (dr/b64-encode-loop s 0 (string-length s) "")))
+
+(define
+  dr/b64-decode-loop
+  (fn
+    (s i n acc)
+    (if
+      (>= i n)
+      acc
+      (let
+        ((p2 (char-at s (+ i 2)))
+          (p3 (char-at s (+ i 3))))
+        (let
+          ((c0 (dr/b64-index (char-at s i)))
+            (c1 (dr/b64-index (char-at s (+ i 1))))
+            (c2 (if (= p2 "=") 0 (dr/b64-index p2)))
+            (c3 (if (= p3 "=") 0 (dr/b64-index p3))))
+          (let
+            ((triple (+ (* c0 262144) (* c1 4096) (* c2 64) c3)))
+            (dr/b64-decode-loop
+              s
+              (+ i 4)
+              n
+              (str
+                acc
+                (char-from-code
+                  (mod (quotient triple 65536) 256))
+                (if
+                  (= p2 "=")
+                  ""
+                  (char-from-code
+                    (mod (quotient triple 256) 256)))
+                (if (= p3 "=") "" (char-from-code (mod triple 256)))))))))))
+
+(define
+  dream-base64-decode
+  (fn
+    (s)
+    (if (= s "") "" (dr/b64-decode-loop s 0 (string-length s) ""))))
+
+;; ── Authorization header parsing ───────────────────────────────────
+(define dream-authorization (fn (req) (dream-header req "authorization")))
+
+(define
+  dream-bearer-token
+  (fn
+    (req)
+    (let
+      ((a (dream-authorization req)))
+      (if (and a (starts-with? a "Bearer ")) (substr a 7) nil))))
+
+(define
+  dream-basic-credentials
+  (fn
+    (req)
+    (let
+      ((a (dream-authorization req)))
+      (if
+        (and a (starts-with? a "Basic "))
+        (let
+          ((decoded (dream-base64-decode (substr a 6))))
+          (let
+            ((colon (index-of decoded ":")))
+            (if (< colon 0) nil {:pass (substr decoded (+ colon 1)) :user (substr decoded 0 colon)})))
+        nil))))
+
+;; ── Basic auth middleware ──────────────────────────────────────────
+;; check is (fn (user pass) -> bool). On success the request gains :dream-user.
+(define
+  dr/www-authenticate
+  (fn
+    (realm)
+    (dream-add-header
+      (dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
+      "www-authenticate"
+      (str "Basic realm=\"" realm "\""))))
+
+(define
+  dream-basic-auth
+  (fn
+    (realm check)
+    (fn
+      (next)
+      (fn
+        (req)
+        (let
+          ((creds (dream-basic-credentials req)))
+          (if
+            (and creds (check (get creds :user) (get creds :pass)))
+            (next (assoc req :dream-user (get creds :user)))
+            (dr/www-authenticate realm)))))))
+
+(define dream-user (fn (req) (get req :dream-user)))
+
+;; ── Bearer-token middleware ────────────────────────────────────────
+;; check is (fn (token) -> principal | nil). On success the request gains
+;; :dream-principal. Missing/invalid -> 401.
+(define
+  dream-require-bearer
+  (fn
+    (check)
+    (fn
+      (next)
+      (fn
+        (req)
+        (let
+          ((tok (dream-bearer-token req)))
+          (let
+            ((principal (if tok (check tok) nil)))
+            (if
+              (nil? principal)
+              (dream-add-header
+                (dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
+                "www-authenticate"
+                "Bearer")
+              (next (assoc req :dream-principal principal)))))))))
+
+(define dream-principal (fn (req) (get req :dream-principal)))

lib/dream/conformance.sh

@@ -0,0 +1,122 @@
+#!/usr/bin/env bash
+# dream-on-sx conformance runner — loads all dream modules + test suites in one
+# sx_server process and reports pass/fail per suite.
+#
+# Usage:
+#   bash lib/dream/conformance.sh        # run all suites
+#   bash lib/dream/conformance.sh -v     # verbose (list each suite)
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="/root/rose-ash/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
+
+VERBOSE="${1:-}"
+
+# Dream library modules loaded before any test suite.
+MODULES=(
+  "lib/dream/types.sx"
+  "lib/dream/router.sx"
+  "lib/dream/middleware.sx"
+  "lib/dream/session.sx"
+  "lib/dream/flash.sx"
+  "lib/dream/form.sx"
+  "lib/dream/websocket.sx"
+  "lib/dream/static.sx"
+  "lib/dream/error.sx"
+  "lib/dream/cors.sx"
+  "lib/dream/json.sx"
+  "lib/dream/auth.sx"
+  "lib/dream/html.sx"
+  "lib/dream/headers.sx"
+  "lib/dream/run.sx"
+  "lib/dream/api.sx"
+  "lib/dream/demos/hello.sx"
+  "lib/dream/demos/counter.sx"
+  "lib/dream/demos/chat.sx"
+  "lib/dream/demos/todo.sx"
+)
+
+# Suites: NAME RUNNER-FN PATH
+SUITES=(
+  "types       dream-ty-tests-run!  lib/dream/tests/types.sx"
+  "router      dream-rt-tests-run!  lib/dream/tests/router.sx"
+  "middleware  dream-mw-tests-run!  lib/dream/tests/middleware.sx"
+  "session     dream-ss-tests-run!  lib/dream/tests/session.sx"
+  "flash       dream-fl-tests-run!  lib/dream/tests/flash.sx"
+  "form        dream-fo-tests-run!  lib/dream/tests/form.sx"
+  "websocket   dream-ws-tests-run!  lib/dream/tests/websocket.sx"
+  "static      dream-st-tests-run!  lib/dream/tests/static.sx"
+  "error       dream-er-tests-run!  lib/dream/tests/error.sx"
+  "cors        dream-co-tests-run!  lib/dream/tests/cors.sx"
+  "json        dream-js-tests-run!  lib/dream/tests/json.sx"
+  "auth        dream-au-tests-run!  lib/dream/tests/auth.sx"
+  "html        dream-ht-tests-run!  lib/dream/tests/html.sx"
+  "headers     dream-hd-tests-run!  lib/dream/tests/headers.sx"
+  "run         dream-rn-tests-run!  lib/dream/tests/run.sx"
+  "api         dream-ap-tests-run!  lib/dream/tests/api.sx"
+  "demos       dream-dm-tests-run!  lib/dream/tests/demos.sx"
+)
+
+TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
+EPOCH=1
+emit_load () { echo "(epoch $EPOCH)"; echo "(load \"$1\")"; EPOCH=$((EPOCH+1)); }
+emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); }
+
+{
+  for M in "${MODULES[@]}"; do emit_load "$M"; done
+  for SUITE in "${SUITES[@]}"; do
+    read -r _NAME _RUNNER FILE <<< "$SUITE"
+    emit_load "$FILE"
+    emit_eval "($_RUNNER)"
+  done
+} > "$TMPFILE"
+
+OUTPUT=$(timeout 540 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
+
+TOTAL_PASS=0
+TOTAL_FAIL=0
+FAILED_SUITES=()
+LAST_DICT_LINES=$(echo "$OUTPUT" | grep -E '^\{:' || true)
+
+I=0
+while read -r LINE; do
+  [ -z "$LINE" ] && continue
+  P=$(echo "$LINE" | grep -oE ':passed [0-9]+' | awk '{print $2}')
+  F=$(echo "$LINE" | grep -oE ':failed [0-9]+' | awk '{print $2}')
+  [ -z "$P" ] && P=0
+  [ -z "$F" ] && F=0
+  SUITE_INFO="${SUITES[$I]}"
+  SUITE_NAME=$(echo "$SUITE_INFO" | awk '{print $1}')
+  TOTAL_PASS=$((TOTAL_PASS + P))
+  TOTAL_FAIL=$((TOTAL_FAIL + F))
+  if [ "$F" -gt 0 ]; then
+    FAILED_SUITES+=("$SUITE_NAME: $P/$((P+F))")
+    printf 'X %-12s %d/%d\n' "$SUITE_NAME" "$P" "$((P+F))"
+    echo "$LINE" | grep -oE ':name "[^"]*"' | sed 's/:name /    fail: /'
+  elif [ "$VERBOSE" = "-v" ]; then
+    printf 'ok %-12s %d passed\n' "$SUITE_NAME" "$P"
+  fi
+  I=$((I+1))
+done <<< "$LAST_DICT_LINES"
+
+TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
+if [ "$TOTAL" -eq 0 ]; then
+  echo "ERROR: no suite results parsed. Raw output:" >&2
+  echo "$OUTPUT" >&2
+  exit 1
+fi
+if [ $TOTAL_FAIL -eq 0 ]; then
+  echo "ok $TOTAL_PASS/$TOTAL dream-on-sx tests passed (${#SUITES[@]} suites)"
+else
+  echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed:"
+  for S in "${FAILED_SUITES[@]}"; do echo "  $S"; done
+  exit 1
+fi

lib/dream/cors.sx

@@ -0,0 +1,51 @@
+;; lib/dream/cors.sx — Dream-on-SX CORS middleware.
+;; Decorates responses with Access-Control-Allow-* headers and short-circuits
+;; preflight OPTIONS requests with a 204. Depends on types.sx.
+
+(define dream-cors-defaults {:methods "GET, POST, PUT, PATCH, DELETE, OPTIONS" :headers "Content-Type" :max-age 86400 :credentials false :origin "*"})
+
+(define
+  dr/cors-origin-headers
+  (fn
+    (opts resp)
+    (let
+      ((r1 (dream-add-header resp "access-control-allow-origin" (get opts :origin))))
+      (if
+        (get opts :credentials)
+        (dream-add-header r1 "access-control-allow-credentials" "true")
+        r1))))
+
+(define
+  dr/cors-preflight
+  (fn
+    (opts)
+    (dr/cors-origin-headers
+      opts
+      (dream-add-header
+        (dream-add-header
+          (dream-add-header
+            (dream-empty 204)
+            "access-control-allow-methods"
+            (get opts :methods))
+          "access-control-allow-headers"
+          (get opts :headers))
+        "access-control-max-age"
+        (str (get opts :max-age))))))
+
+(define
+  dream-cors-with
+  (fn
+    (opts)
+    (fn
+      (next)
+      (fn
+        (req)
+        (if
+          (= (dream-method req) "OPTIONS")
+          (dr/cors-preflight opts)
+          (dr/cors-origin-headers opts (next req)))))))
+
+(define dream-cors (dream-cors-with dream-cors-defaults))
+(define
+  dream-cors-origin
+  (fn (origin) (dream-cors-with (assoc dream-cors-defaults :origin origin))))

lib/dream/demos/chat.sx

@@ -0,0 +1,46 @@
+;; lib/dream/demos/chat.sx — multi-room WebSocket chat (chat.ml).
+;; A room registry holds the live connections per room; each ws session joins its
+;; room, broadcasts every received message to the room, and leaves on close.
+
+(define dream-chat-rooms (fn () (let ((rooms {})) {:join (fn (room ws) (set! rooms (assoc rooms room (concat (or (get rooms room) (list)) (list ws))))) :broadcast (fn (room msg) (for-each (fn (w) (dream-send w msg)) (or (get rooms room) (list)))) :members (fn (room) (or (get rooms room) (list))) :leave (fn (room ws) (set! rooms (assoc rooms room (filter (fn (w) (not (= w ws))) (or (get rooms room) (list))))))})))
+
+(define
+  dream-chat-loop
+  (fn
+    (rooms room ws)
+    (let
+      ((m (dream-receive ws)))
+      (if
+        (nil? m)
+        (begin ((get rooms :leave) room ws) (dream-close ws))
+        (begin
+          ((get rooms :broadcast) room m)
+          (dream-chat-loop rooms room ws))))))
+
+(define
+  dream-chat-session
+  (fn
+    (rooms room)
+    (fn
+      (ws)
+      (begin ((get rooms :join) room ws) (dream-chat-loop rooms room ws)))))
+
+(define
+  dream-chat-route
+  (fn
+    (rooms)
+    (fn
+      (req)
+      ((dream-websocket (dream-chat-session rooms (dream-param req "room")))
+        req))))
+
+(define
+  dream-chat-app-with
+  (fn
+    (rooms)
+    (dream-router
+      (list
+        (dream-get "/" (fn (req) (dream-html "<h1>Rooms</h1>")))
+        (dream-get "/chat/:room" (dream-chat-route rooms))))))
+
+;; entry point: (dream-run (dream-chat-app-with (dream-chat-rooms)))

lib/dream/demos/counter.sx

@@ -0,0 +1,35 @@
+;; lib/dream/demos/counter.sx — per-session visit counter (counter.ml).
+;; Demonstrates the session middleware: each browser session keeps its own count.
+
+(define
+  dream-counter-handler
+  (fn
+    (req)
+    (let
+      ((n (+ 1 (or (dream-session-field req "count") 0))))
+      (begin
+        (dream-set-session-field req "count" n)
+        (dream-html (str "<p>You have visited this page " n " time(s).</p>"))))))
+
+;; reset clears the session counter
+(define
+  dream-counter-reset
+  (fn
+    (req)
+    (begin
+      (dream-set-session-field req "count" 0)
+      (dream-redirect "/"))))
+
+(define
+  dream-counter-app-with
+  (fn
+    (backend)
+    ((dream-sessions backend)
+      (dream-router
+        (list
+          (dream-get "/" dream-counter-handler)
+          (dream-post "/reset" dream-counter-reset))))))
+
+(define dream-counter-app (dream-counter-app-with (dream-memory-sessions)))
+
+;; entry point: (dream-run (dream-counter-app-with (dream-memory-sessions)))

lib/dream/demos/hello.sx

@@ -0,0 +1,16 @@
+;; lib/dream/demos/hello.sx — the canonical Dream "Hello, World!" (hello.ml).
+;; Dream.run (Dream.router [Dream.get "/" (fun _ -> Dream.html "Hello!")]).
+
+(define
+  dream-hello-app
+  (dream-router
+    (list
+      (dream-get "/" (fn (req) (dream-html "<h1>Hello, World!</h1>")))
+      (dream-get
+        "/hello/:name"
+        (fn
+          (req)
+          (dream-html (str "<h1>Hello, " (dream-param req "name") "!</h1>")))))))
+
+;; entry point (installs the handler on the host):
+;;   (dream-run dream-hello-app)

lib/dream/demos/todo.sx

@@ -0,0 +1,96 @@
+;; lib/dream/demos/todo.sx — CRUD todo list with forms + CSRF (todo.ml).
+;; An in-memory store holds items; add/toggle/delete go through POST forms guarded
+;; by the CSRF middleware. User text is HTML-escaped on render (dream-escape).
+;; Wires session -> csrf -> router.
+
+(define
+  dream-todo-store
+  (fn () (let ((items (list)) (next-id 0)) {:all (fn () items) :add (fn (text) (begin (set! next-id (+ next-id 1)) (set! items (concat items (list {:id next-id :text text :done false}))) next-id)) :delete (fn (id) (set! items (filter (fn (it) (not (= (get it :id) id))) items))) :toggle (fn (id) (set! items (map (fn (it) (if (= (get it :id) id) (assoc it :done (not (get it :done))) it)) items)))})))
+
+(define
+  dr/todo-render
+  (fn
+    (store req)
+    (str
+      "<ul>"
+      (reduce
+        (fn
+          (acc it)
+          (str
+            acc
+            "<li>"
+            (if (get it :done) "[x] " "[ ] ")
+            (dream-escape (get it :text))
+            "</li>"))
+        ""
+        ((get store :all)))
+      "</ul>"
+      "<form method=\"post\" action=\"/add\">"
+      (dream-csrf-tag req)
+      "<input name=\"text\"><button>Add</button></form>")))
+
+(define
+  dream-todo-index
+  (fn (store) (fn (req) (dream-html (dr/todo-render store req)))))
+
+(define
+  dream-todo-add
+  (fn
+    (store)
+    (fn
+      (req)
+      (let
+        ((r (dream-form req)))
+        (if
+          (dream-ok? r)
+          (begin
+            ((get store :add) (get (dream-ok-value r) "text"))
+            (dream-redirect "/"))
+          (dream-html-status
+            403
+            (str "Rejected: " (dream-err-reason r))))))))
+
+(define
+  dream-todo-toggle
+  (fn
+    (store)
+    (fn
+      (req)
+      (let
+        ((r (dream-form req)))
+        (if
+          (dream-ok? r)
+          (begin
+            ((get store :toggle) (parse-int (dream-param req "id")))
+            (dream-redirect "/"))
+          (dream-html-status 403 "Rejected"))))))
+
+(define
+  dream-todo-delete
+  (fn
+    (store)
+    (fn
+      (req)
+      (let
+        ((r (dream-form req)))
+        (if
+          (dream-ok? r)
+          (begin
+            ((get store :delete) (parse-int (dream-param req "id")))
+            (dream-redirect "/"))
+          (dream-html-status 403 "Rejected"))))))
+
+(define
+  dream-todo-app-with
+  (fn
+    (store backend secret)
+    ((dream-sessions backend)
+      ((dream-csrf secret)
+        (dream-router
+          (list
+            (dream-get "/" (dream-todo-index store))
+            (dream-post "/add" (dream-todo-add store))
+            (dream-post "/toggle/:id" (dream-todo-toggle store))
+            (dream-post "/delete/:id" (dream-todo-delete store))))))))
+
+;; entry: (dream-run (dream-todo-app-with (dream-todo-store) (dream-memory-sessions) "change-me"))

lib/dream/error.sx

@@ -0,0 +1,41 @@
+;; lib/dream/error.sx — Dream-on-SX status phrases + error-handling middleware.
+;; dream-catch wraps a handler and turns a raised error into a 500 response (or a
+;; custom page). Depends on types.sx.
+
+;; ── status reason phrases ──────────────────────────────────────────
+(define dr/status-texts {:206 "Partial Content" :202 "Accepted" :422 "Unprocessable Entity" :400 "Bad Request" :302 "Found" :204 "No Content" :502 "Bad Gateway" :429 "Too Many Requests" :301 "Moved Permanently" :415 "Unsupported Media Type" :405 "Method Not Allowed" :303 "See Other" :401 "Unauthorized" :304 "Not Modified" :503 "Service Unavailable" :404 "Not Found" :308 "Permanent Redirect" :504 "Gateway Timeout" :416 "Range Not Satisfiable" :500 "Internal Server Error" :307 "Temporary Redirect" :201 "Created" :501 "Not Implemented" :409 "Conflict" :200 "OK" :410 "Gone" :403 "Forbidden"})
+
+(define
+  dream-status-text
+  (fn (status) (or (get dr/status-texts (str status)) "Unknown")))
+(define
+  dream-status-line
+  (fn (status) (str status " " (dream-status-text status))))
+
+;; ── error-handling middleware ──────────────────────────────────────
+(define
+  dream-default-error-page
+  (fn
+    (req e)
+    (dream-html-status
+      500
+      (str "<h1>" (dream-status-line 500) "</h1>"))))
+
+(define
+  dream-catch-with
+  (fn
+    (on-error)
+    (fn
+      (next)
+      (fn (req) (guard (e (true (on-error req e))) (next req))))))
+
+(define dream-catch (dream-catch-with dream-default-error-page))
+
+;; a fallback handler that renders a status page for any code
+(define
+  dream-status-page
+  (fn
+    (status)
+    (dream-html-status
+      status
+      (str "<h1>" (dream-status-line status) "</h1>"))))

lib/dream/flash.sx

@@ -0,0 +1,91 @@
+;; lib/dream/flash.sx — Dream-on-SX flash messages.
+;; A single-request cookie store: messages added during one request are read on
+;; the NEXT request, then the cookie is cleared. Depends on types.sx + session.sx
+;; (shared cookie helpers). A message is {:category c :message m}.
+
+;; ── cookie codec ───────────────────────────────────────────────────
+;; escape the field separators so categories/messages round-trip safely
+(define
+  dr/flash-esc
+  (fn (s) (replace (replace (replace s "%" "%25") "|" "%7C") "~" "%7E")))
+(define
+  dr/flash-unesc
+  (fn (s) (replace (replace (replace s "%7E" "~") "%7C" "|") "%25" "%")))
+
+(define
+  dr/flash-encode
+  (fn
+    (msgs)
+    (join
+      "~"
+      (map
+        (fn
+          (m)
+          (str
+            (dr/flash-esc (get m :category))
+            "|"
+            (dr/flash-esc (get m :message))))
+        msgs))))
+
+(define
+  dr/flash-decode
+  (fn
+    (s)
+    (if
+      (= s "")
+      (list)
+      (map
+        (fn (part) (let ((i (index-of part "|"))) {:message (dr/flash-unesc (substr part (+ i 1))) :category (dr/flash-unesc (substr part 0 i))}))
+        (split s "~")))))
+
+;; ── mutable outbox cell ────────────────────────────────────────────
+(define dr/flash-box (fn () (let ((items (list))) {:add (fn (x) (set! items (concat items (list x)))) :get (fn () items)})))
+
+;; ── middleware ─────────────────────────────────────────────────────
+(define dream-flash-cookie-name "dream.flash")
+
+(define
+  dream-flash
+  (fn
+    (next)
+    (fn
+      (req)
+      (let
+        ((incoming (dr/flash-decode (or (dream-cookie req dream-flash-cookie-name) "")))
+          (box (dr/flash-box)))
+        (let
+          ((resp (next (assoc req :dream-flash {:box box :incoming incoming}))))
+          (let
+            ((out ((get box :get))))
+            (cond
+              ((not (empty? out))
+                (dream-set-cookie
+                  resp
+                  dream-flash-cookie-name
+                  (dr/flash-encode out)
+                  {:path "/" :http-only true :same-site "Lax"}))
+              ((not (empty? incoming))
+                (dream-drop-cookie resp dream-flash-cookie-name))
+              (else resp))))))))
+
+;; ── handler-facing API ─────────────────────────────────────────────
+(define
+  dream-add-flash-message
+  (fn
+    (req category msg)
+    (begin ((get (get (get req :dream-flash) :box) :add) {:message msg :category category}) req)))
+
+(define
+  dream-flash-messages
+  (fn (req) (get (get req :dream-flash) :incoming)))
+(define dream-flash-category (fn (m) (get m :category)))
+(define dream-flash-message (fn (m) (get m :message)))
+
+;; convenience: only messages of a given category
+(define
+  dream-flash-of
+  (fn
+    (req category)
+    (filter
+      (fn (m) (= (get m :category) category))
+      (dream-flash-messages req))))

lib/dream/form.sx

@@ -0,0 +1,366 @@
+;; lib/dream/form.sx — Dream-on-SX forms + CSRF.
+;; Parses application/x-www-form-urlencoded bodies; CSRF tokens are stateless,
+;; signed, and session-scoped. The signing function is injectable (a pure-SX keyed
+;; hash by default — production should swap in a host HMAC). Depends on types.sx +
+;; session.sx. dream-form returns an Ok/Err result value.
+
+;; ── Result (Ok/Err) ────────────────────────────────────────────────
+(define dream-ok (fn (v) {:value v :result "ok"}))
+(define dream-err (fn (r) {:reason r :result "err"}))
+(define dream-ok? (fn (x) (= (get x :result) "ok")))
+(define dream-err? (fn (x) (= (get x :result) "err")))
+(define dream-ok-value (fn (x) (get x :value)))
+(define dream-err-reason (fn (x) (get x :reason)))
+
+;; ── percent decoding ───────────────────────────────────────────────
+(define
+  dr/hex-digit
+  (fn
+    (c)
+    (let
+      ((n (char-code c)))
+      (cond
+        ((and (>= n 48) (<= n 57)) (- n 48))
+        ((and (>= n 65) (<= n 70))
+          (+ 10 (- n 65)))
+        ((and (>= n 97) (<= n 102))
+          (+ 10 (- n 97)))
+        (else 0)))))
+
+(define
+  dr/url-decode-loop
+  (fn
+    (s i n acc)
+    (if
+      (>= i n)
+      acc
+      (let
+        ((c (char-at s i)))
+        (if
+          (and (= c "%") (< (+ i 2) n))
+          (dr/url-decode-loop
+            s
+            (+ i 3)
+            n
+            (str
+              acc
+              (char-from-code
+                (+
+                  (* 16 (dr/hex-digit (char-at s (+ i 1))))
+                  (dr/hex-digit (char-at s (+ i 2)))))))
+          (dr/url-decode-loop s (+ i 1) n (str acc c)))))))
+
+(define
+  dr/url-decode
+  (fn
+    (s)
+    (let
+      ((s2 (replace s "+" " ")))
+      (dr/url-decode-loop s2 0 (string-length s2) ""))))
+
+;; ── substring splitter (split primitive is char-class based) ───────
+(define
+  dr/split-on
+  (fn
+    (s sep)
+    (let
+      ((i (index-of s sep)))
+      (if
+        (< i 0)
+        (list s)
+        (cons
+          (substr s 0 i)
+          (dr/split-on (substr s (+ i (string-length sep))) sep))))))
+
+;; ── urlencoded body parsing ────────────────────────────────────────
+(define
+  dr/parse-form-body
+  (fn
+    (body)
+    (if
+      (= body "")
+      {}
+      (reduce
+        (fn
+          (acc pair)
+          (if
+            (= pair "")
+            acc
+            (let
+              ((j (index-of pair "=")))
+              (if
+                (< j 0)
+                (assoc acc (dr/url-decode pair) "")
+                (assoc
+                  acc
+                  (dr/url-decode (substr pair 0 j))
+                  (dr/url-decode (substr pair (+ j 1))))))))
+        {}
+        (split body "&")))))
+
+;; raw fields, no CSRF check
+(define dream-form-fields (fn (req) (dr/parse-form-body (dream-body req))))
+(define
+  dream-form-field
+  (fn (req name) (get (dream-form-fields req) name)))
+
+;; ── CSRF signing (injectable; pure-SX keyed hash default) ──────────
+(define
+  dr/poly-hash
+  (fn (s base seed) (dr/poly-loop s 0 (string-length s) seed base)))
+(define
+  dr/poly-loop
+  (fn
+    (s i n h base)
+    (if
+      (>= i n)
+      h
+      (dr/poly-loop
+        s
+        (+ i 1)
+        n
+        (mod (+ (* h base) (char-code (char-at s i))) 2147483647)
+        base))))
+
+;; NOTE: not cryptographic — adequate to demonstrate stateless CSRF; production
+;; should inject a real HMAC via dream-csrf-with.
+(define
+  dream-csrf-sign-default
+  (fn
+    (secret msg)
+    (let
+      ((m (str secret "|" msg)))
+      (str
+        (dr/poly-hash m 131 7)
+        "-"
+        (dr/poly-hash m 137 13)))))
+
+(define dream-csrf-field-name "dream.csrf")
+
+(define
+  dr/csrf-make-token
+  (fn (sign secret sid) (str sid "." (sign secret sid))))
+
+(define
+  dr/csrf-valid?
+  (fn
+    (sign secret sid token)
+    (if
+      (or (nil? token) (= token ""))
+      false
+      (let
+        ((dot (index-of token ".")))
+        (if
+          (< dot 0)
+          false
+          (let
+            ((tsid (substr token 0 dot))
+              (tsig (substr token (+ dot 1))))
+            (and (= tsid sid) (= tsig (sign secret sid)))))))))
+
+;; ── CSRF middleware: attach signing context (needs session upstream) ──
+(define
+  dream-csrf-with
+  (fn
+    (secret sign)
+    (fn (next) (fn (req) (next (assoc req :dream-csrf {:sign sign :sid (dream-session-id req) :secret secret}))))))
+
+(define
+  dream-csrf
+  (fn (secret) (dream-csrf-with secret dream-csrf-sign-default)))
+
+(define dr/csrf-of (fn (req) (get req :dream-csrf)))
+
+;; current token + hidden-input tag for templates
+(define
+  dream-csrf-token
+  (fn
+    (req)
+    (let
+      ((c (dr/csrf-of req)))
+      (dr/csrf-make-token (get c :sign) (get c :secret) (get c :sid)))))
+
+(define
+  dream-csrf-tag
+  (fn
+    (req)
+    (str
+      "<input type=\"hidden\" name=\""
+      dream-csrf-field-name
+      "\" value=\""
+      (dream-csrf-token req)
+      "\">")))
+
+;; ── dream-form: parse + verify CSRF -> Ok fields | Err reason ──────
+(define
+  dream-form
+  (fn
+    (req)
+    (let
+      ((c (dr/csrf-of req)))
+      (if
+        (nil? c)
+        (dream-err :csrf-context-missing)
+        (let
+          ((fields (dream-form-fields req)))
+          (if
+            (dr/csrf-valid?
+              (get c :sign)
+              (get c :secret)
+              (get c :sid)
+              (get fields dream-csrf-field-name))
+            (dream-ok fields)
+            (dream-err :csrf-token-invalid)))))))
+
+;; ── CSRF auto-rejecting middleware (unsafe methods need a valid token) ──
+(define
+  dr/csrf-safe-method?
+  (fn (m) (or (= m "GET") (= m "HEAD") (= m "OPTIONS"))))
+
+(define
+  dream-csrf-protect-with
+  (fn
+    (secret sign)
+    (fn
+      (next)
+      (fn
+        (req)
+        (let
+          ((req2 (assoc req :dream-csrf {:sign sign :sid (dream-session-id req) :secret secret})))
+          (if
+            (dr/csrf-safe-method? (dream-method req2))
+            (next req2)
+            (let
+              ((token (get (dream-form-fields req2) dream-csrf-field-name)))
+              (if
+                (dr/csrf-valid? sign secret (dream-session-id req2) token)
+                (next req2)
+                (dream-html-status 403 "CSRF token invalid")))))))))
+
+(define
+  dream-csrf-protect
+  (fn (secret) (dream-csrf-protect-with secret dream-csrf-sign-default)))
+
+;; ── multipart/form-data parsing ────────────────────────────────────
+;; In-memory (not yet streaming): parses the whole body into parts, each
+;; {:name :filename :content-type :content}. Returns Ok parts | Err :not-multipart.
+(define
+  dr/multipart-boundary
+  (fn
+    (ctype)
+    (let
+      ((i (index-of ctype "boundary=")))
+      (if
+        (< i 0)
+        ""
+        (let
+          ((raw (trim (substr ctype (+ i 9)))))
+          (if
+            (starts-with? raw "\"")
+            (substr raw 1 (- (string-length raw) 2))
+            raw))))))
+
+;; strip one leading and one trailing CRLF
+(define
+  dr/strip-edges
+  (fn
+    (s)
+    (let
+      ((s1 (if (starts-with? s "\r\n") (substr s 2) s)))
+      (if
+        (ends-with? s1 "\r\n")
+        (substr s1 0 (- (string-length s1) 2))
+        s1))))
+
+;; value of attr="..." within a header block
+(define
+  dr/cd-attr
+  (fn
+    (block attr)
+    (let
+      ((key (str attr "=\"")))
+      (let
+        ((i (index-of block key)))
+        (if
+          (< i 0)
+          nil
+          (let
+            ((rest (substr block (+ i (string-length key)))))
+            (substr rest 0 (index-of rest "\""))))))))
+
+;; value of a named header line within a header block
+(define
+  dr/block-header
+  (fn
+    (block name)
+    (reduce
+      (fn
+        (acc line)
+        (if
+          (and
+            (nil? acc)
+            (starts-with? (lower line) (str (lower name) ":")))
+          (trim (substr line (+ (index-of line ":") 1)))
+          acc))
+      nil
+      (dr/split-on block "\r\n"))))
+
+(define
+  dr/parse-part
+  (fn
+    (seg)
+    (let
+      ((s (dr/strip-edges seg)))
+      (let
+        ((sp (index-of s "\r\n\r\n")))
+        (if
+          (< sp 0)
+          nil
+          (let
+            ((block (substr s 0 sp))
+              (content (substr s (+ sp 4))))
+            {:name (dr/cd-attr block "name") :filename (dr/cd-attr block "filename") :content-type (dr/block-header block "content-type") :content content}))))))
+
+(define
+  dream-multipart
+  (fn
+    (req)
+    (let
+      ((boundary (dr/multipart-boundary (or (dream-header req "content-type") ""))))
+      (if
+        (= boundary "")
+        (dream-err :not-multipart)
+        (let
+          ((segs (dr/split-on (dream-body req) (str "--" boundary))))
+          (dream-ok
+            (filter
+              (fn (p) (not (nil? p)))
+              (map
+                dr/parse-part
+                (filter (fn (seg) (starts-with? seg "\r\n")) segs)))))))))
+
+;; accessors over a parts list
+(define
+  dream-multipart-field
+  (fn
+    (parts name)
+    (reduce
+      (fn
+        (acc p)
+        (if (and (nil? acc) (= (get p :name) name)) (get p :content) acc))
+      nil
+      parts)))
+
+(define
+  dream-multipart-file
+  (fn
+    (parts name)
+    (reduce
+      (fn
+        (acc p)
+        (if
+          (and (nil? acc) (= (get p :name) name) (get p :filename))
+          p
+          acc))
+      nil
+      parts)))

lib/dream/headers.sx

@@ -0,0 +1,54 @@
+;; lib/dream/headers.sx — Dream-on-SX security headers + cache-control helpers.
+;; Depends on types.sx.
+
+;; ── security headers middleware ────────────────────────────────────
+(define dream-security-defaults {:x-frame-options "DENY" :referrer-policy "no-referrer" :x-content-type-options "nosniff" :hsts false})
+
+(define
+  dr/apply-security
+  (fn
+    (opts resp)
+    (let
+      ((r1 (dream-add-header (dream-add-header (dream-add-header resp "x-content-type-options" (get opts :x-content-type-options)) "x-frame-options" (get opts :x-frame-options)) "referrer-policy" (get opts :referrer-policy))))
+      (if
+        (get opts :hsts)
+        (dream-add-header
+          r1
+          "strict-transport-security"
+          "max-age=31536000; includeSubDomains")
+        r1))))
+
+(define
+  dream-security-headers-with
+  (fn (opts) (fn (next) (fn (req) (dr/apply-security opts (next req))))))
+(define
+  dream-security-headers
+  (dream-security-headers-with dream-security-defaults))
+
+;; ── cache-control response helpers ─────────────────────────────────
+(define
+  dream-cache
+  (fn
+    (resp seconds)
+    (dream-add-header resp "cache-control" (str "public, max-age=" seconds))))
+(define
+  dream-private-cache
+  (fn
+    (resp seconds)
+    (dream-add-header resp "cache-control" (str "private, max-age=" seconds))))
+(define
+  dream-no-store
+  (fn (resp) (dream-add-header resp "cache-control" "no-store")))
+(define
+  dream-no-cache
+  (fn
+    (resp)
+    (dream-add-header
+      resp
+      "cache-control"
+      "no-cache, no-store, must-revalidate")))
+
+;; cache-control middleware: stamp a max-age on every response
+(define
+  dream-cache-for
+  (fn (seconds) (fn (next) (fn (req) (dream-cache (next req) seconds)))))

lib/dream/html.sx

@@ -0,0 +1,24 @@
+;; lib/dream/html.sx — Dream-on-SX HTML escaping for safe templating.
+;; Interpolating user input into HTML without escaping is an XSS hole; dream-escape
+;; neutralises it. Depends on nothing (pure string ops).
+
+;; escape text for HTML element content / double-quoted attributes
+(define
+  dream-escape
+  (fn
+    (s)
+    (replace
+      (replace
+        (replace (replace (replace s "&" "&amp;") "<" "&lt;") ">" "&gt;")
+        "\""
+        "&quot;")
+      "'"
+      "&#39;")))
+
+;; build a single attribute: name="escaped-value"
+(define dream-attr (fn (name val) (str name "=\"" (dream-escape val) "\"")))
+
+;; join escaped text with a separator, escaping each piece
+(define
+  dream-escape-join
+  (fn (sep pieces) (join sep (map dream-escape pieces))))

lib/dream/json.sx

@@ -0,0 +1,183 @@
+;; lib/dream/json.sx — Dream-on-SX JSON encode/parse (pure SX).
+;; The host JSON primitives live in the ocaml-on-sx runtime, not the base env, so
+;; Dream ships its own. Depends on types.sx. (number? is unreliable in this env —
+;; type-of "number" is used instead.)
+
+;; ── encoding ───────────────────────────────────────────────────────
+(define
+  dr/json-escape
+  (fn
+    (s)
+    (replace
+      (replace
+        (replace (replace (replace s "\\" "\\\\") "\"" "\\\"") "\n" "\\n")
+        "\r"
+        "\\r")
+      "\t"
+      "\\t")))
+(define dr/json-quote (fn (s) (str "\"" (dr/json-escape s) "\"")))
+
+(define
+  dream-json-encode
+  (fn
+    (v)
+    (cond
+      ((nil? v) "null")
+      ((boolean? v) (if v "true" "false"))
+      ((= (type-of v) "number") (str v))
+      ((string? v) (dr/json-quote v))
+      ((list? v) (str "[" (join "," (map dream-json-encode v)) "]"))
+      ((dict? v)
+        (str
+          "{"
+          (join
+            ","
+            (map
+              (fn
+                (k)
+                (str (dr/json-quote k) ":" (dream-json-encode (get v k))))
+              (keys v)))
+          "}"))
+      (else (dr/json-quote (str v))))))
+
+;; ── parsing (recursive descent; returns {:val :pos}) ───────────────
+(define
+  dr/json-space?
+  (fn (c) (or (= c " ") (= c "\n") (= c "\r") (= c "\t"))))
+(define
+  dr/json-ws
+  (fn
+    (s i)
+    (if
+      (and (< i (string-length s)) (dr/json-space? (char-at s i)))
+      (dr/json-ws s (+ i 1))
+      i)))
+
+(define
+  dr/json-digit?
+  (fn
+    (c)
+    (let ((n (char-code c))) (and (>= n 48) (<= n 57)))))
+(define
+  dr/json-num-char?
+  (fn
+    (c)
+    (or
+      (dr/json-digit? c)
+      (= c "-")
+      (= c "+")
+      (= c ".")
+      (= c "e")
+      (= c "E"))))
+(define
+  dr/json-num-end
+  (fn
+    (s i)
+    (if
+      (and (< i (string-length s)) (dr/json-num-char? (char-at s i)))
+      (dr/json-num-end s (+ i 1))
+      i)))
+(define
+  dr/json-to-number
+  (fn
+    (str-val)
+    (if
+      (or
+        (contains? str-val ".")
+        (contains? str-val "e")
+        (contains? str-val "E"))
+      (parse-float str-val)
+      (parse-int str-val))))
+
+(define
+  dr/json-str
+  (fn
+    (s i acc)
+    (let
+      ((c (char-at s i)))
+      (cond
+        ((= c "\"") {:val acc :pos (+ i 1)})
+        ((= c "\\")
+          (let
+            ((e (char-at s (+ i 1))))
+            (cond
+              ((= e "n") (dr/json-str s (+ i 2) (str acc "\n")))
+              ((= e "r") (dr/json-str s (+ i 2) (str acc "\r")))
+              ((= e "t") (dr/json-str s (+ i 2) (str acc "\t")))
+              (else (dr/json-str s (+ i 2) (str acc e))))))
+        (else (dr/json-str s (+ i 1) (str acc c)))))))
+
+(define
+  dr/json-num
+  (fn (s i) (let ((j (dr/json-num-end s i))) {:val (dr/json-to-number (substr s i (- j i))) :pos j})))
+
+(define
+  dr/json-arr
+  (fn
+    (s i acc)
+    (let
+      ((i (dr/json-ws s i)))
+      (if
+        (= (char-at s i) "]")
+        {:val acc :pos (+ i 1)}
+        (let
+          ((r (dr/json-val s i)))
+          (let
+            ((i2 (dr/json-ws s (get r :pos))))
+            (if
+              (= (char-at s i2) ",")
+              (dr/json-arr
+                s
+                (+ i2 1)
+                (concat acc (list (get r :val))))
+              {:val (concat acc (list (get r :val))) :pos (+ i2 1)})))))))
+
+(define
+  dr/json-obj
+  (fn
+    (s i acc)
+    (let
+      ((i (dr/json-ws s i)))
+      (if
+        (= (char-at s i) "}")
+        {:val acc :pos (+ i 1)}
+        (let
+          ((kr (dr/json-str s (+ i 1) "")))
+          (let
+            ((i2 (dr/json-ws s (get kr :pos))))
+            (let
+              ((vr (dr/json-val s (+ i2 1))))
+              (let
+                ((i3 (dr/json-ws s (get vr :pos))))
+                (if
+                  (= (char-at s i3) ",")
+                  (dr/json-obj
+                    s
+                    (+ i3 1)
+                    (assoc acc (get kr :val) (get vr :val)))
+                  {:val (assoc acc (get kr :val) (get vr :val)) :pos (+ i3 1)})))))))))
+
+(define
+  dr/json-val
+  (fn
+    (s i)
+    (let
+      ((i (dr/json-ws s i)))
+      (let
+        ((c (char-at s i)))
+        (cond
+          ((= c "{") (dr/json-obj s (+ i 1) {}))
+          ((= c "[") (dr/json-arr s (+ i 1) (list)))
+          ((= c "\"") (dr/json-str s (+ i 1) ""))
+          ((= c "t") {:val true :pos (+ i 4)})
+          ((= c "f") {:val false :pos (+ i 5)})
+          ((= c "n") {:val nil :pos (+ i 4)})
+          (else (dr/json-num s i)))))))
+
+(define dream-json-parse (fn (s) (get (dr/json-val s 0) :val)))
+
+;; ── responses ──────────────────────────────────────────────────────
+;; encode a value into a JSON response (dream-json takes a raw string body)
+(define dream-json-value (fn (v) (dream-json (dream-json-encode v))))
+;; read + parse the request body as JSON
+(define dream-json-body (fn (req) (dream-json-parse (dream-body req))))

lib/dream/middleware.sx

@@ -0,0 +1,92 @@
+;; lib/dream/middleware.sx — Dream-on-SX middleware.
+;; A middleware is handler->handler. Composition is plain function composition:
+;; m1 @@ m2 @@ handler = (m1 (m2 handler)). Depends on types.sx + router.sx
+;; (reuses dr/apply-middlewares for the fold).
+
+;; ── composition ────────────────────────────────────────────────────
+;; (dream-pipeline (list m1 m2 m3) handler) = (m1 (m2 (m3 handler))).
+(define
+  dream-pipeline
+  (fn (middlewares handler) (dr/apply-middlewares middlewares handler)))
+
+;; identity middleware
+(define dream-no-middleware (fn (next) next))
+
+;; ── logger ─────────────────────────────────────────────────────────
+;; Parameterised on a clock and a sink so it is testable without IO.
+;; sink receives {:method :path :status :elapsed}.
+(define
+  dream-logger-with
+  (fn
+    (clock sink)
+    (fn
+      (next)
+      (fn
+        (req)
+        (let
+          ((t0 (clock)))
+          (let ((resp (next req))) (begin (sink {:path (dream-path req) :status (dream-status resp) :method (dream-method req) :elapsed (- (clock) t0)}) resp)))))))
+
+;; default logger performs host effects for the clock and the log sink
+(define
+  dream-logger
+  (dream-logger-with
+    (fn () (perform (:dream-clock)))
+    (fn (entry) (perform (:dream-log entry)))))
+
+;; format a log entry as a one-line string (apache-ish)
+(define
+  dream-log-line
+  (fn
+    (entry)
+    (str
+      (get entry :method)
+      " "
+      (get entry :path)
+      " -> "
+      (get entry :status)
+      " ("
+      (get entry :elapsed)
+      "ms)")))
+
+;; ── content-type sniffer ───────────────────────────────────────────
+(define
+  dr/sniff-content-type
+  (fn
+    (body)
+    (cond
+      ((= body "") "text/plain; charset=utf-8")
+      ((starts-with? body "<") "text/html; charset=utf-8")
+      ((starts-with? body "{") "application/json")
+      ((starts-with? body "[") "application/json")
+      (else "text/plain; charset=utf-8"))))
+
+;; sets Content-Type from the body only when the handler left it unset
+(define
+  dream-content-type
+  (fn
+    (next)
+    (fn
+      (req)
+      (let
+        ((resp (next req)))
+        (if
+          (dream-resp-header resp "content-type")
+          resp
+          (dream-add-header
+            resp
+            "content-type"
+            (dr/sniff-content-type (dream-resp-body resp))))))))
+
+;; ── small reusable middlewares ─────────────────────────────────────
+;; always attach a response header
+(define
+  dream-set-header
+  (fn
+    (name val)
+    (fn (next) (fn (req) (dream-add-header (next req) name val)))))
+
+;; rewrite/observe the request before the handler sees it
+(define
+  dream-tap-request
+  (fn (f) (fn (next) (fn (req) (next (f req))))))

lib/dream/router.sx

@@ -0,0 +1,170 @@
+;; lib/dream/router.sx — Dream-on-SX routing.
+;; Routes are dicts {:method :path :handler}; a router is a handler that
+;; dispatches request -> response by method + path, extracting :name path
+;; params and binding a ** catch-all. No path match -> 404; path matches but
+;; method doesn't -> 405 + Allow. HEAD falls back to the GET handler with an
+;; empty body. Depends on types.sx.
+
+;; ── route constructors (one per HTTP method) ───────────────────────
+(define dream-get (fn (path handler) (dream-route "GET" path handler)))
+(define dream-post (fn (path handler) (dream-route "POST" path handler)))
+(define dream-put (fn (path handler) (dream-route "PUT" path handler)))
+(define
+  dream-delete
+  (fn (path handler) (dream-route "DELETE" path handler)))
+(define dream-patch (fn (path handler) (dream-route "PATCH" path handler)))
+(define dream-head (fn (path handler) (dream-route "HEAD" path handler)))
+(define
+  dream-options
+  (fn (path handler) (dream-route "OPTIONS" path handler)))
+(define dream-any (fn (path handler) (dream-route "ANY" path handler)))
+
+;; ── path segmentation ──────────────────────────────────────────────
+;; "/users/42/" -> ("users" "42"); "/" -> ()
+(define
+  dr/segs
+  (fn (path) (filter (fn (s) (not (= s ""))) (split path "/"))))
+
+(define
+  dr/join-path
+  (fn
+    (prefix path)
+    (str "/" (join "/" (concat (dr/segs prefix) (dr/segs path))))))
+
+;; ── segment matching ───────────────────────────────────────────────
+;; Returns a params dict on match (possibly empty {}), nil on no match.
+(define
+  dr/match-segs
+  (fn
+    (pat path params)
+    (cond
+      ((and (empty? pat) (empty? path)) params)
+      ((empty? pat) nil)
+      (else
+        (let
+          ((ps (first pat)))
+          (cond
+            ((= ps "**") (assoc params "**" (join "/" path)))
+            ((empty? path) nil)
+            ((starts-with? ps ":")
+              (dr/match-segs
+                (rest pat)
+                (rest path)
+                (assoc params (substr ps 1) (first path))))
+            ((= ps (first path))
+              (dr/match-segs (rest pat) (rest path) params))
+            (else nil)))))))
+
+;; path-only match: returns params dict or nil
+(define
+  dr/route-params
+  (fn
+    (r req)
+    (dr/match-segs
+      (dr/segs (dream-route-path r))
+      (dr/segs (dream-path req))
+      {})))
+
+;; method acceptance: exact, ANY, or HEAD served by a GET route
+(define
+  dr/method-accepts?
+  (fn
+    (route-method req-method)
+    (or
+      (= route-method "ANY")
+      (= route-method req-method)
+      (and (= req-method "HEAD") (= route-method "GET")))))
+
+;; ── middleware pipeline (shared with middleware.sx) ────────────────
+;; m1 @@ m2 @@ handler = (m1 (m2 handler)); first in list is outermost.
+(define
+  dr/apply-middlewares
+  (fn (mws handler) (reduce (fn (h mw) (mw h)) handler (reverse mws))))
+
+;; ── scope: prefix mount + middleware chain ─────────────────────────
+;; Returns a flat list of routes; nested scopes flatten correctly.
+(define
+  dr/flatten-routes
+  (fn
+    (items)
+    (reduce
+      (fn
+        (acc it)
+        (if
+          (dream-route? it)
+          (concat acc (list it))
+          (concat acc (dr/flatten-routes it))))
+      (list)
+      items)))
+
+(define
+  dream-scope
+  (fn
+    (prefix middlewares routes)
+    (map
+      (fn
+        (r)
+        (dream-route
+          (dream-route-method r)
+          (dr/join-path prefix (dream-route-path r))
+          (dr/apply-middlewares middlewares (dream-route-handler r))))
+      (dr/flatten-routes routes))))
+
+;; ── dispatch ───────────────────────────────────────────────────────
+;; allowed = methods of routes whose PATH matched (for 405 + Allow).
+(define
+  dr/dispatch
+  (fn
+    (routes req allowed)
+    (if
+      (empty? routes)
+      (if
+        (empty? allowed)
+        (dream-not-found)
+        (dream-method-not-allowed allowed))
+      (let
+        ((r (first routes)))
+        (let
+          ((params (dr/route-params r req)))
+          (if
+            (nil? params)
+            (dr/dispatch (rest routes) req allowed)
+            (if
+              (dr/method-accepts? (dream-route-method r) (dream-method req))
+              (dr/run-route r req params)
+              (dr/dispatch
+                (rest routes)
+                req
+                (concat allowed (list (dream-route-method r)))))))))))
+
+;; run a matched route; blank the body for an auto-HEAD on a GET route
+(define
+  dr/run-route
+  (fn
+    (r req params)
+    (let
+      ((resp (dream-coerce-response ((dream-route-handler r) (dream-with-params req params)))))
+      (if
+        (and
+          (= (dream-method req) "HEAD")
+          (not (= (dream-route-method r) "HEAD")))
+        (dream-response (dream-status resp) (dream-headers resp) "")
+        resp))))
+
+;; 405 response with an Allow header listing the path's methods
+(define
+  dream-method-not-allowed
+  (fn
+    (allowed)
+    (dream-add-header
+      (dream-response 405 {:content-type "text/plain; charset=utf-8"} "Method Not Allowed")
+      "allow"
+      (join ", " allowed))))
+
+(define
+  dream-router
+  (fn
+    (routes)
+    (let
+      ((flat (dr/flatten-routes routes)))
+      (fn (req) (dr/dispatch flat req (list))))))

lib/dream/run.sx

@@ -0,0 +1,42 @@
+;; lib/dream/run.sx — Dream-on-SX entry point.
+;; dream-run installs a root handler into the existing SX HTTP server via
+;; (perform (:http/listen …)) — it does NOT implement its own socket loop. The
+;; host invokes the installed app per request with a raw request dict; the app
+;; adapts it to a dream-request, runs the handler, and serialises the response
+;; (status/headers/body/set-cookies, or a websocket upgrade). Depends on types.sx
+;; + websocket.sx. The listen transport is injectable for testing.
+
+;; ── response serialisation for the host ────────────────────────────
+(define
+  dr/serialize-response
+  (fn (resp) (if (dream-websocket? resp) {:websocket (dream-ws-handler resp) :body "" :headers (dream-headers resp) :status 101 :set-cookies (list)} {:body (dream-resp-body resp) :headers (dream-headers resp) :status (dream-status resp) :set-cookies (dream-resp-cookies resp)})))
+
+;; ── the app: raw host request -> serialised response ───────────────
+(define
+  dream-app
+  (fn
+    (handler)
+    (fn
+      (raw)
+      (let
+        ((req (dream-request (or (get raw :method) "GET") (or (get raw :target) (or (get raw :path) "/")) (or (get raw :headers) {}) (or (get raw :body) ""))))
+        (dr/serialize-response (dream-coerce-response (handler req)))))))
+
+;; ── dream-run ──────────────────────────────────────────────────────
+(define dream-default-port 8080)
+
+(define dream-run-with (fn (listen handler opts) (listen {:op "http/listen" :port (or (get opts :port) dream-default-port) :app (dream-app handler) :host (or (get opts :host) "0.0.0.0")})))
+
+(define dream-perform-listen (fn (op) (perform op)))
+
+(define
+  dream-run
+  (fn (handler) (dream-run-with dream-perform-listen handler {})))
+(define
+  dream-run-port
+  (fn
+    (handler port)
+    (dream-run-with dream-perform-listen handler {:port port})))
+(define
+  dream-run-opts
+  (fn (handler opts) (dream-run-with dream-perform-listen handler opts)))

lib/dream/session.sx

@@ -0,0 +1,238 @@
+;; lib/dream/session.sx — Dream-on-SX cookie-backed sessions.
+;; The session cookie carries only a session id; fields live in a back-end store.
+;; The store is injectable: production wires it to (perform op); tests pass an
+;; in-memory store. Depends on types.sx. Also hosts shared cookie helpers reused
+;; by flash.sx and form.sx.
+
+;; ── cookie helpers (shared) ────────────────────────────────────────
+(define
+  dr/parse-cookies
+  (fn
+    (header)
+    (if
+      (or (nil? header) (= header ""))
+      {}
+      (reduce
+        (fn
+          (acc part)
+          (let
+            ((kv (trim part)))
+            (let
+              ((j (index-of kv "=")))
+              (if
+                (< j 0)
+                acc
+                (assoc
+                  acc
+                  (substr kv 0 j)
+                  (substr kv (+ j 1)))))))
+        {}
+        (split header ";")))))
+
+(define
+  dream-cookie
+  (fn (req name) (get (dr/parse-cookies (dream-header req "cookie")) name)))
+(define
+  dream-cookies
+  (fn (req) (dr/parse-cookies (dream-header req "cookie"))))
+
+(define
+  dr/build-cookie
+  (fn
+    (name val opts)
+    (let
+      ((o (if (nil? opts) {} opts)))
+      (str
+        name
+        "="
+        val
+        "; Path="
+        (or (get o :path) "/")
+        (if (get o :http-only) "; HttpOnly" "")
+        (if (get o :secure) "; Secure" "")
+        (if (get o :same-site) (str "; SameSite=" (get o :same-site)) "")
+        (if (get o :max-age) (str "; Max-Age=" (get o :max-age)) "")))))
+
+(define
+  dream-set-cookie
+  (fn
+    (resp name val opts)
+    (assoc
+      resp
+      :set-cookies (concat
+        (or (get resp :set-cookies) (list))
+        (list (dr/build-cookie name val opts))))))
+
+(define
+  dream-resp-cookies
+  (fn (resp) (or (get resp :set-cookies) (list))))
+
+;; expire a cookie on the client
+(define
+  dream-drop-cookie
+  (fn (resp name) (dream-set-cookie resp name "" {:max-age 0})))
+
+;; ── signed cookie values (tamper-evident) ──────────────────────────
+;; NOTE: pure-SX keyed hash — not cryptographic; production should inject a host
+;; HMAC. Value carries no "." so the first "." splits value from signature.
+(define
+  dr/sess-hash
+  (fn (s) (dr/sess-hash-loop s 0 (string-length s) 7)))
+(define
+  dr/sess-hash-loop
+  (fn
+    (s i n h)
+    (if
+      (>= i n)
+      h
+      (dr/sess-hash-loop
+        s
+        (+ i 1)
+        n
+        (mod (+ (* h 131) (char-code (char-at s i))) 2147483647)))))
+(define
+  dr/sess-sig
+  (fn (secret val) (str (dr/sess-hash (str secret "|" val)))))
+
+(define
+  dream-cookie-sign
+  (fn (secret val) (str val "." (dr/sess-sig secret val))))
+(define
+  dream-cookie-unsign
+  (fn
+    (secret signed)
+    (if
+      (or (nil? signed) (= signed ""))
+      nil
+      (let
+        ((dot (index-of signed ".")))
+        (if
+          (< dot 0)
+          nil
+          (let
+            ((val (substr signed 0 dot))
+              (sig (substr signed (+ dot 1))))
+            (if (= sig (dr/sess-sig secret val)) val nil)))))))
+
+;; ── in-memory session store (tests + demos) ────────────────────────
+;; A backend is (fn (op) result) where op is a dict {:op ... :sid ... :key ...}.
+(define
+  dream-memory-sessions
+  (fn
+    ()
+    (let
+      ((store {}) (counter 0))
+      (fn
+        (op)
+        (let
+          ((kind (get op :op)))
+          (cond
+            ((= kind "session/create")
+              (begin
+                (set! counter (+ counter 1))
+                (let
+                  ((sid (str "s" counter)))
+                  (begin (set! store (assoc store sid {})) sid))))
+            ((= kind "session/exists") (has-key? store (get op :sid)))
+            ((= kind "session/get")
+              (get (or (get store (get op :sid)) {}) (get op :key)))
+            ((= kind "session/set")
+              (let
+                ((sid (get op :sid)))
+                (set!
+                  store
+                  (assoc
+                    store
+                    sid
+                    (assoc
+                      (or (get store sid) {})
+                      (get op :key)
+                      (get op :val))))))
+            ((= kind "session/load")
+              (or (get store (get op :sid)) {}))
+            ((= kind "session/clear")
+              (set! store (dissoc store (get op :sid))))
+            (else nil)))))))
+
+;; production back-end: every op suspends to the host
+(define dream-perform-sessions (fn (op) (perform op)))
+
+;; ── session middleware ─────────────────────────────────────────────
+(define dream-session-cookie-name "dream.session")
+
+(define
+  dream-sessions
+  (fn
+    (backend)
+    (fn
+      (next)
+      (fn
+        (req)
+        (let
+          ((sid0 (dream-cookie req dream-session-cookie-name)))
+          (let
+            ((have (and sid0 (backend {:op "session/exists" :sid sid0}))))
+            (let
+              ((sid (if have sid0 (backend {:op "session/create"}))))
+              (let
+                ((resp (next (assoc req :dream-session {:io backend :sid sid}))))
+                (if
+                  have
+                  resp
+                  (dream-set-cookie
+                    resp
+                    dream-session-cookie-name
+                    sid
+                    {:path "/" :http-only true :same-site "Lax"}))))))))))
+
+;; signed variant: the cookie value is signed so a guessed/forged sid is rejected
+(define
+  dream-sessions-signed
+  (fn
+    (backend secret)
+    (fn
+      (next)
+      (fn
+        (req)
+        (let
+          ((sid0 (dream-cookie-unsign secret (dream-cookie req dream-session-cookie-name))))
+          (let
+            ((have (and sid0 (backend {:op "session/exists" :sid sid0}))))
+            (let
+              ((sid (if have sid0 (backend {:op "session/create"}))))
+              (let
+                ((resp (next (assoc req :dream-session {:io backend :sid sid}))))
+                (if
+                  have
+                  resp
+                  (dream-set-cookie
+                    resp
+                    dream-session-cookie-name
+                    (dream-cookie-sign secret sid)
+                    {:path "/" :http-only true :same-site "Lax"}))))))))))
+
+;; ── handler-facing session API ─────────────────────────────────────
+(define dr/session-of (fn (req) (get req :dream-session)))
+(define dream-session-id (fn (req) (get (dr/session-of req) :sid)))
+
+(define
+  dream-session-field
+  (fn
+    (req key)
+    (let ((s (dr/session-of req))) ((get s :io) {:key key :op "session/get" :sid (get s :sid)}))))
+
+(define
+  dream-set-session-field
+  (fn
+    (req key val)
+    (let ((s (dr/session-of req))) (begin ((get s :io) {:val val :key key :op "session/set" :sid (get s :sid)}) req))))
+
+(define
+  dream-session-all
+  (fn (req) (let ((s (dr/session-of req))) ((get s :io) {:op "session/load" :sid (get s :sid)}))))
+
+(define
+  dream-invalidate-session
+  (fn
+    (req)
+    (let ((s (dr/session-of req))) (begin ((get s :io) {:op "session/clear" :sid (get s :sid)}) req))))

lib/dream/static.sx

@@ -0,0 +1,182 @@
+;; lib/dream/static.sx — Dream-on-SX static file serving.
+;; dream-static mounts at a ** route and serves files under a root: content-type by
+;; extension, ETags + If-None-Match (304), and Range requests (206). The filesystem
+;; is injectable: production reads via (perform op); tests pass an in-memory map.
+;; Depends on types.sx.
+
+;; ── filesystem backends ────────────────────────────────────────────
+;; An fs is (fn (op) result); op {:op "file/read" :path p} -> content | nil.
+(define dream-static-perform-fs (fn (op) (perform op)))
+
+;; in-memory fs over a {path -> content} dict (tests + demos)
+(define
+  dream-memory-fs
+  (fn
+    (files)
+    (fn
+      (op)
+      (if (= (get op :op) "file/read") (get files (get op :path)) nil))))
+
+;; ── content-type by extension ──────────────────────────────────────
+(define dr/mime-types {:js "application/javascript" :jpeg "image/jpeg" :css "text/css; charset=utf-8" :ico "image/x-icon" :mjs "application/javascript" :html "text/html; charset=utf-8" :pdf "application/pdf" :jpg "image/jpeg" :json "application/json" :htm "text/html; charset=utf-8" :wasm "application/wasm" :webp "image/webp" :gif "image/gif" :png "image/png" :svg "image/svg+xml" :md "text/markdown; charset=utf-8" :xml "application/xml" :sx "text/plain; charset=utf-8" :txt "text/plain; charset=utf-8"})
+
+(define
+  dr/ext-of
+  (fn
+    (path)
+    (let
+      ((segs (split path ".")))
+      (if
+        (> (len segs) 1)
+        (lower (nth segs (- (len segs) 1)))
+        ""))))
+
+(define
+  dream-content-type-for
+  (fn
+    (path)
+    (or (get dr/mime-types (dr/ext-of path)) "application/octet-stream")))
+
+;; ── ETag (weak content hash) ───────────────────────────────────────
+(define
+  dr/static-hash
+  (fn (s) (dr/static-hash-loop s 0 (string-length s) 7)))
+(define
+  dr/static-hash-loop
+  (fn
+    (s i n h)
+    (if
+      (>= i n)
+      h
+      (dr/static-hash-loop
+        s
+        (+ i 1)
+        n
+        (mod (+ (* h 131) (char-code (char-at s i))) 2147483647)))))
+(define
+  dr/etag-of
+  (fn
+    (content)
+    (str "\"" (dr/static-hash content) "-" (string-length content) "\"")))
+(define
+  dr/etag-match?
+  (fn (inm etag) (and (not (nil? inm)) (or (= inm "*") (= inm etag)))))
+
+;; ── path safety ────────────────────────────────────────────────────
+(define
+  dr/static-relpath
+  (fn
+    (req)
+    (or (dream-param req "**") (substr (dream-path req) 1))))
+(define
+  dr/unsafe-path?
+  (fn (rel) (or (contains? rel "..") (starts-with? rel "/")))) 
+(define
+  dr/path-join
+  (fn
+    (root rel)
+    (if (ends-with? root "/") (str root rel) (str root "/" rel))))
+
+;; ── range requests ─────────────────────────────────────────────────
+(define
+  dr/parse-range
+  (fn
+    (header total)
+    (let
+      ((eq (index-of header "=")))
+      (if
+        (< eq 0)
+        nil
+        (let
+          ((spec (substr header (+ eq 1))))
+          (let
+            ((dash (index-of spec "-")))
+            (if
+              (< dash 0)
+              nil
+              (let
+                ((s (substr spec 0 dash))
+                  (e (substr spec (+ dash 1))))
+                (let
+                  ((start (if (= s "") 0 (parse-int s)))
+                    (end (if (= e "") (- total 1) (parse-int e))))
+                  (if
+                    (or
+                      (< start 0)
+                      (>= start total)
+                      (> end (- total 1))
+                      (> start end))
+                    nil
+                    {:start start :end end}))))))))))
+
+(define
+  dr/serve-range
+  (fn
+    (req content etag ctype)
+    (let
+      ((total (string-length content)))
+      (let
+        ((r (dr/parse-range (dream-header req "range") total)))
+        (if
+          (nil? r)
+          (dream-add-header
+            (dream-response 416 {:content-type ctype} "")
+            "content-range"
+            (str "bytes */" total))
+          (let
+            ((start (get r :start)) (end (get r :end)))
+            (dream-add-header
+              (dream-add-header
+                (dream-response
+                  206
+                  {:content-type ctype}
+                  (substr content start (+ 1 (- end start))))
+                "content-range"
+                (str "bytes " start "-" end "/" total))
+              "etag"
+              etag)))))))
+
+;; ── serving ────────────────────────────────────────────────────────
+(define
+  dr/serve-file
+  (fn
+    (req content)
+    (let
+      ((rel (dr/static-relpath req)))
+      (let
+        ((etag (dr/etag-of content)) (ctype (dream-content-type-for rel)))
+        (cond
+          ((dr/etag-match? (dream-header req "if-none-match") etag)
+            (dream-add-header (dream-empty 304) "etag" etag))
+          ((dream-header req "range")
+            (dr/serve-range req content etag ctype))
+          (else
+            (dream-add-header
+              (dream-add-header
+                (dream-response 200 {:content-type ctype} content)
+                "etag"
+                etag)
+              "accept-ranges"
+              "bytes")))))))
+
+(define
+  dream-static-with
+  (fn
+    (root fs)
+    (fn
+      (req)
+      (let
+        ((rel (dr/static-relpath req)))
+        (if
+          (dr/unsafe-path? rel)
+          (dream-html-status 403 "Forbidden")
+          (let
+            ((content (fs {:path (dr/path-join root rel) :op "file/read"})))
+            (if
+              (nil? content)
+              (dream-not-found)
+              (dr/serve-file req content))))))))
+
+(define
+  dream-static
+  (fn (root) (dream-static-with root dream-static-perform-fs)))

lib/dream/tests/api.sx

@@ -0,0 +1,77 @@
+;; lib/dream/tests/api.sx — facade: app builders + default stack.
+
+(define dream-ap-pass 0)
+(define dream-ap-fail 0)
+(define dream-ap-fails (list))
+
+(define
+  dream-ap-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-ap-pass (+ dream-ap-pass 1))
+      (begin
+        (set! dream-ap-fail (+ dream-ap-fail 1))
+        (append! dream-ap-fails {:name name :actual actual :expected expected})))))
+
+(dream-ap-test "version is a string" (string? dream-version) true)
+
+;; ── dream-make-app: routes -> handler with default stack ───────────
+(define
+  dream-ap-routes
+  (list
+    (dream-get "/" (fn (req) (dream-html "<h1>hi</h1>")))
+    (dream-get "/boom" (fn (req) (error "kaboom")))
+    (dream-get
+      "/raw"
+      (fn (req) (dream-response 200 {} "plain words")))))
+(define dream-ap-app (dream-make-app dream-ap-routes))
+
+(dream-ap-test
+  "app serves"
+  (dream-resp-body (dream-ap-app (dream-request "GET" "/" {} "")))
+  "<h1>hi</h1>")
+(dream-ap-test
+  "app catches errors -> 500"
+  (dream-status (dream-ap-app (dream-request "GET" "/boom" {} "")))
+  500)
+(dream-ap-test
+  "app 404 for unknown"
+  (dream-status (dream-ap-app (dream-request "GET" "/nope" {} "")))
+  404)
+(dream-ap-test
+  "app sniffs content-type"
+  (dream-resp-header
+    (dream-ap-app (dream-request "GET" "/raw" {} ""))
+    "content-type")
+  "text/plain; charset=utf-8")
+
+;; ── dream-make-app-with: extra outer middleware ────────────────────
+(define
+  dream-ap-tag
+  (fn (next) (fn (req) (dream-add-header (next req) "X-App" "1"))))
+(define
+  dream-ap-app2
+  (dream-make-app-with (list dream-ap-tag) dream-ap-routes))
+(dream-ap-test
+  "extra middleware header"
+  (dream-resp-header
+    (dream-ap-app2 (dream-request "GET" "/" {} ""))
+    "x-app")
+  "1")
+
+;; ── dream-serve wires through dream-run ────────────────────────────
+(define dream-ap-captured nil)
+(define dream-ap-listen (fn (op) (begin (set! dream-ap-captured op) :ok)))
+(define
+  dream-ap-served
+  (dream-run-with dream-ap-listen (dream-make-app dream-ap-routes) {:port 7000}))
+(dream-ap-test "serve listens" dream-ap-served :ok)
+(dream-ap-test "serve port" (get dream-ap-captured :port) 7000)
+(dream-ap-test
+  "served app runs"
+  (get ((get dream-ap-captured :app) {:method "GET" :target "/"}) :body)
+  "<h1>hi</h1>")
+
+(define dream-ap-tests-run! (fn () {:total (+ dream-ap-pass dream-ap-fail) :passed dream-ap-pass :failed dream-ap-fail :fails dream-ap-fails}))

lib/dream/tests/auth.sx

@@ -0,0 +1,109 @@
+;; lib/dream/tests/auth.sx — base64, basic auth, bearer tokens.
+
+(define dream-au-pass 0)
+(define dream-au-fail 0)
+(define dream-au-fails (list))
+
+(define
+  dream-au-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-au-pass (+ dream-au-pass 1))
+      (begin
+        (set! dream-au-fail (+ dream-au-fail 1))
+        (append! dream-au-fails {:name name :actual actual :expected expected})))))
+
+;; ── base64 ─────────────────────────────────────────────────────────
+(dream-au-test "encode Man" (dream-base64-encode "Man") "TWFu")
+(dream-au-test "encode Ma" (dream-base64-encode "Ma") "TWE=")
+(dream-au-test "encode M" (dream-base64-encode "M") "TQ==")
+(dream-au-test
+  "encode user:pass"
+  (dream-base64-encode "user:pass")
+  "dXNlcjpwYXNz")
+(dream-au-test "decode Man" (dream-base64-decode "TWFu") "Man")
+(dream-au-test "decode Ma" (dream-base64-decode "TWE=") "Ma")
+(dream-au-test "decode M" (dream-base64-decode "TQ==") "M")
+(dream-au-test
+  "decode user:pass"
+  (dream-base64-decode "dXNlcjpwYXNz")
+  "user:pass")
+(dream-au-test
+  "roundtrip phrase"
+  (dream-base64-decode (dream-base64-encode "Hello, World!"))
+  "Hello, World!")
+(dream-au-test
+  "roundtrip empty"
+  (dream-base64-decode (dream-base64-encode ""))
+  "")
+
+;; ── header parsing ─────────────────────────────────────────────────
+(dream-au-test
+  "bearer token"
+  (dream-bearer-token (dream-request "GET" "/" {:Authorization "Bearer abc.123"} ""))
+  "abc.123")
+(dream-au-test
+  "no bearer"
+  (dream-bearer-token (dream-request "GET" "/" {} ""))
+  nil)
+(dream-au-test
+  "basic creds"
+  (dream-basic-credentials (dream-request "GET" "/" {:Authorization "Basic dXNlcjpwYXNz"} ""))
+  {:pass "pass" :user "user"})
+(dream-au-test
+  "no basic"
+  (dream-basic-credentials (dream-request "GET" "/" {} ""))
+  nil)
+
+;; ── basic auth middleware ──────────────────────────────────────────
+(define dream-au-check (fn (u p) (and (= u "admin") (= p "secret"))))
+(define
+  dream-au-app
+  ((dream-basic-auth "Admin Area" dream-au-check)
+    (fn (req) (dream-text (str "hi " (dream-user req))))))
+
+(define dream-au-ok (dream-au-app (dream-request "GET" "/" {:Authorization (str "Basic " (dream-base64-encode "admin:secret"))} "")))
+(dream-au-test "basic ok reaches" (dream-resp-body dream-au-ok) "hi admin")
+(dream-au-test "basic ok status" (dream-status dream-au-ok) 200)
+
+(define dream-au-bad (dream-au-app (dream-request "GET" "/" {:Authorization (str "Basic " (dream-base64-encode "admin:wrong"))} "")))
+(dream-au-test "basic wrong 401" (dream-status dream-au-bad) 401)
+(dream-au-test
+  "basic wrong www-authenticate"
+  (contains? (dream-resp-header dream-au-bad "www-authenticate") "Admin Area")
+  true)
+(dream-au-test
+  "basic missing 401"
+  (dream-status (dream-au-app (dream-request "GET" "/" {} "")))
+  401)
+
+;; ── bearer middleware ──────────────────────────────────────────────
+(define dream-au-tokens {:t-ada "ada" :t-bob "bob"})
+(define dream-au-lookup (fn (tok) (get dream-au-tokens tok)))
+(define
+  dream-au-bapp
+  ((dream-require-bearer dream-au-lookup)
+    (fn (req) (dream-text (dream-principal req)))))
+
+(dream-au-test
+  "bearer valid principal"
+  (dream-resp-body (dream-au-bapp (dream-request "GET" "/" {:Authorization "Bearer t-ada"} "")))
+  "ada")
+(dream-au-test
+  "bearer invalid 401"
+  (dream-status (dream-au-bapp (dream-request "GET" "/" {:Authorization "Bearer nope"} "")))
+  401)
+(dream-au-test
+  "bearer missing 401"
+  (dream-status (dream-au-bapp (dream-request "GET" "/" {} "")))
+  401)
+(dream-au-test
+  "bearer 401 header"
+  (dream-resp-header
+    (dream-au-bapp (dream-request "GET" "/" {} ""))
+    "www-authenticate")
+  "Bearer")
+
+(define dream-au-tests-run! (fn () {:total (+ dream-au-pass dream-au-fail) :passed dream-au-pass :failed dream-au-fail :fails dream-au-fails}))

lib/dream/tests/cors.sx

@@ -0,0 +1,93 @@
+;; lib/dream/tests/cors.sx — CORS decoration + preflight.
+
+(define dream-co-pass 0)
+(define dream-co-fail 0)
+(define dream-co-fails (list))
+
+(define
+  dream-co-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-co-pass (+ dream-co-pass 1))
+      (begin
+        (set! dream-co-fail (+ dream-co-fail 1))
+        (append! dream-co-fails {:name name :actual actual :expected expected})))))
+
+(define dream-co-h (fn (req) (dream-text "payload")))
+(define dream-co-app (dream-cors dream-co-h))
+
+;; ── decoration of normal responses ─────────────────────────────────
+(define dream-co-get (dream-co-app (dream-request "GET" "/" {} "")))
+(dream-co-test
+  "allow-origin star"
+  (dream-resp-header dream-co-get "access-control-allow-origin")
+  "*")
+(dream-co-test "body preserved" (dream-resp-body dream-co-get) "payload")
+(dream-co-test "status preserved" (dream-status dream-co-get) 200)
+(dream-co-test
+  "no credentials by default"
+  (dream-resp-header dream-co-get "access-control-allow-credentials")
+  nil)
+
+;; ── preflight OPTIONS ──────────────────────────────────────────────
+(define
+  dream-co-pre
+  (dream-co-app (dream-request "OPTIONS" "/" {} "")))
+(dream-co-test "preflight 204" (dream-status dream-co-pre) 204)
+(dream-co-test
+  "preflight origin"
+  (dream-resp-header dream-co-pre "access-control-allow-origin")
+  "*")
+(dream-co-test
+  "preflight methods"
+  (contains?
+    (dream-resp-header dream-co-pre "access-control-allow-methods")
+    "POST")
+  true)
+(dream-co-test
+  "preflight headers"
+  (dream-resp-header dream-co-pre "access-control-allow-headers")
+  "Content-Type")
+(dream-co-test
+  "preflight max-age"
+  (dream-resp-header dream-co-pre "access-control-max-age")
+  "86400")
+
+;; ── custom origin ──────────────────────────────────────────────────
+(define
+  dream-co-custom
+  ((dream-cors-origin "https://app.example.com") dream-co-h))
+(dream-co-test
+  "custom origin"
+  (dream-resp-header
+    (dream-co-custom (dream-request "GET" "/" {} ""))
+    "access-control-allow-origin")
+  "https://app.example.com")
+
+;; ── credentials enabled ────────────────────────────────────────────
+(define
+  dream-co-cred
+  ((dream-cors-with (assoc dream-cors-defaults :credentials true))
+    dream-co-h))
+(dream-co-test
+  "credentials header"
+  (dream-resp-header
+    (dream-co-cred (dream-request "GET" "/" {} ""))
+    "access-control-allow-credentials")
+  "true")
+
+;; ── composes around a router ───────────────────────────────────────
+(define
+  dream-co-router
+  (dream-cors
+    (dream-router (list (dream-get "/api" (fn (req) (dream-json "{}")))))))
+(dream-co-test
+  "router cors origin"
+  (dream-resp-header
+    (dream-co-router (dream-request "GET" "/api" {} ""))
+    "access-control-allow-origin")
+  "*")
+
+(define dream-co-tests-run! (fn () {:total (+ dream-co-pass dream-co-fail) :passed dream-co-pass :failed dream-co-fail :fails dream-co-fails}))

lib/dream/tests/demos.sx

@@ -0,0 +1,198 @@
+;; lib/dream/tests/demos.sx — end-to-end demo apps exercising the full stack.
+
+(define dream-dm-pass 0)
+(define dream-dm-fail 0)
+(define dream-dm-fails (list))
+
+(define
+  dream-dm-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-dm-pass (+ dream-dm-pass 1))
+      (begin
+        (set! dream-dm-fail (+ dream-dm-fail 1))
+        (append! dream-dm-fails {:name name :actual actual :expected expected})))))
+
+(define
+  dream-dm-req
+  (fn (method target headers) (dream-request method target headers "")))
+
+;; ── hello ──────────────────────────────────────────────────────────
+(dream-dm-test
+  "hello root"
+  (dream-resp-body (dream-hello-app (dream-dm-req "GET" "/" {})))
+  "<h1>Hello, World!</h1>")
+(dream-dm-test
+  "hello name"
+  (dream-resp-body
+    (dream-hello-app (dream-dm-req "GET" "/hello/Ada" {})))
+  "<h1>Hello, Ada!</h1>")
+(dream-dm-test
+  "hello content-type"
+  (dream-resp-header
+    (dream-hello-app (dream-dm-req "GET" "/" {}))
+    "content-type")
+  "text/html; charset=utf-8")
+
+;; ── counter (sessions) ─────────────────────────────────────────────
+(define dream-dm-cbackend (dream-memory-sessions))
+(define dream-dm-capp (dream-counter-app-with dream-dm-cbackend))
+
+(define dream-dm-c1 (dream-dm-capp (dream-dm-req "GET" "/" {})))
+(dream-dm-test
+  "counter first visit"
+  (dream-resp-body dream-dm-c1)
+  "<p>You have visited this page 1 time(s).</p>")
+(dream-dm-test
+  "counter sets cookie"
+  (len (dream-resp-cookies dream-dm-c1))
+  1)
+(dream-dm-test
+  "counter second visit"
+  (dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {:Cookie "dream.session=s1"})))
+  "<p>You have visited this page 2 time(s).</p>")
+(dream-dm-test
+  "counter third visit"
+  (dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {:Cookie "dream.session=s1"})))
+  "<p>You have visited this page 3 time(s).</p>")
+(define
+  dream-dm-reset
+  (dream-dm-capp (dream-dm-req "POST" "/reset" {:Cookie "dream.session=s1"})))
+(dream-dm-test
+  "counter reset redirects"
+  (dream-status dream-dm-reset)
+  303)
+(dream-dm-test
+  "counter after reset"
+  (dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {:Cookie "dream.session=s1"})))
+  "<p>You have visited this page 1 time(s).</p>")
+(dream-dm-test
+  "counter distinct session"
+  (dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {})))
+  "<p>You have visited this page 1 time(s).</p>")
+
+;; ── chat (websocket rooms) ─────────────────────────────────────────
+(define dream-dm-rooms (dream-chat-rooms))
+(define dream-dm-wsB (dream-mock-ws (list)))
+(define dream-dm-wsC (dream-mock-ws (list)))
+((get dream-dm-rooms :join) "general" dream-dm-wsB)
+((get dream-dm-rooms :join) "general" dream-dm-wsC)
+(dream-dm-test
+  "room has two members"
+  (len ((get dream-dm-rooms :members) "general"))
+  2)
+
+;; client A joins, sends two messages, then disconnects
+(define dream-dm-wsA (dream-mock-ws (list "hi" "again")))
+((dream-chat-session dream-dm-rooms "general") dream-dm-wsA)
+(dream-dm-test
+  "B got broadcasts"
+  (dream-ws-sent dream-dm-wsB)
+  (list "hi" "again"))
+(dream-dm-test
+  "C got broadcasts"
+  (dream-ws-sent dream-dm-wsC)
+  (list "hi" "again"))
+(dream-dm-test
+  "A echoed own messages"
+  (dream-ws-sent dream-dm-wsA)
+  (list "hi" "again"))
+(dream-dm-test
+  "A left on disconnect"
+  (len ((get dream-dm-rooms :members) "general"))
+  2)
+(dream-dm-test "A closed" (dream-ws-closed? dream-dm-wsA) true)
+
+;; route produces an upgrade response
+(define dream-dm-chat-app (dream-chat-app-with (dream-chat-rooms)))
+(dream-dm-test
+  "chat route upgrades"
+  (dream-websocket?
+    (dream-dm-chat-app (dream-dm-req "GET" "/chat/lobby" {})))
+  true)
+(dream-dm-test
+  "chat index html"
+  (dream-resp-body (dream-dm-chat-app (dream-dm-req "GET" "/" {})))
+  "<h1>Rooms</h1>")
+
+;; ── todo (forms + CSRF) ────────────────────────────────────────────
+(define dream-dm-todo-store (dream-todo-store))
+(define dream-dm-todo-backend (dream-memory-sessions))
+(define
+  dream-dm-todo-app
+  (dream-todo-app-with dream-dm-todo-store dream-dm-todo-backend "topsecret"))
+(define
+  dream-dm-todo-tok
+  (dr/csrf-make-token dream-csrf-sign-default "topsecret" "s1"))
+
+;; establish session s1
+(dream-dm-todo-app (dream-request "GET" "/" {} ""))
+(define
+  dream-dm-add1
+  (dream-dm-todo-app
+    (dream-request
+      "POST"
+      "/add"
+      {:Cookie "dream.session=s1"}
+      (str "text=Buy+milk&dream.csrf=" dream-dm-todo-tok))))
+(dream-dm-test "todo add redirects" (dream-status dream-dm-add1) 303)
+(dream-dm-test
+  "todo store has item"
+  (len ((get dream-dm-todo-store :all)))
+  1)
+
+(define
+  dream-dm-todo-page
+  (dream-resp-body
+    (dream-dm-todo-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} ""))))
+(dream-dm-test
+  "todo lists item"
+  (contains? dream-dm-todo-page "Buy milk")
+  true)
+(dream-dm-test
+  "todo has csrf tag"
+  (contains? dream-dm-todo-page "dream.csrf")
+  true)
+(dream-dm-test
+  "todo item not done"
+  (contains? dream-dm-todo-page "[ ] Buy milk")
+  true)
+
+(dream-dm-todo-app
+  (dream-request
+    "POST"
+    "/toggle/1"
+    {:Cookie "dream.session=s1"}
+    (str "dream.csrf=" dream-dm-todo-tok)))
+(dream-dm-test
+  "todo toggled done"
+  (contains?
+    (dream-resp-body
+      (dream-dm-todo-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
+    "[x] Buy milk")
+  true)
+
+(dream-dm-test
+  "todo add without token 403"
+  (dream-status
+    (dream-dm-todo-app (dream-request "POST" "/add" {:Cookie "dream.session=s1"} "text=Sneaky")))
+  403)
+(dream-dm-test
+  "todo unchanged after reject"
+  (len ((get dream-dm-todo-store :all)))
+  1)
+
+(dream-dm-todo-app
+  (dream-request
+    "POST"
+    "/delete/1"
+    {:Cookie "dream.session=s1"}
+    (str "dream.csrf=" dream-dm-todo-tok)))
+(dream-dm-test
+  "todo deleted"
+  (len ((get dream-dm-todo-store :all)))
+  0)
+
+(define dream-dm-tests-run! (fn () {:total (+ dream-dm-pass dream-dm-fail) :passed dream-dm-pass :failed dream-dm-fail :fails dream-dm-fails}))

lib/dream/tests/error.sx

@@ -0,0 +1,90 @@
+;; lib/dream/tests/error.sx — status phrases + dream-catch.
+
+(define dream-er-pass 0)
+(define dream-er-fail 0)
+(define dream-er-fails (list))
+
+(define
+  dream-er-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-er-pass (+ dream-er-pass 1))
+      (begin
+        (set! dream-er-fail (+ dream-er-fail 1))
+        (append! dream-er-fails {:name name :actual actual :expected expected})))))
+
+;; ── status phrases ─────────────────────────────────────────────────
+(dream-er-test "200 OK" (dream-status-text 200) "OK")
+(dream-er-test "404 Not Found" (dream-status-text 404) "Not Found")
+(dream-er-test
+  "405 phrase"
+  (dream-status-text 405)
+  "Method Not Allowed")
+(dream-er-test
+  "500 phrase"
+  (dream-status-text 500)
+  "Internal Server Error")
+(dream-er-test "unknown phrase" (dream-status-text 599) "Unknown")
+(dream-er-test "status line" (dream-status-line 404) "404 Not Found")
+(dream-er-test
+  "status page status"
+  (dream-status (dream-status-page 403))
+  403)
+(dream-er-test
+  "status page body"
+  (dream-resp-body (dream-status-page 403))
+  "<h1>403 Forbidden</h1>")
+
+;; ── dream-catch ────────────────────────────────────────────────────
+(define dream-er-boom (fn (req) (error "kaboom")))
+(define dream-er-ok (fn (req) (dream-text "fine")))
+
+(dream-er-test
+  "catch normal passes through"
+  (dream-resp-body
+    ((dream-catch dream-er-ok) (dream-request "GET" "/" {} "")))
+  "fine")
+(dream-er-test
+  "catch error -> 500"
+  (dream-status
+    ((dream-catch dream-er-boom) (dream-request "GET" "/" {} "")))
+  500)
+(dream-er-test
+  "catch 500 body"
+  (dream-resp-body
+    ((dream-catch dream-er-boom) (dream-request "GET" "/" {} "")))
+  "<h1>500 Internal Server Error</h1>")
+
+;; custom error page receives the error
+(define
+  dream-er-custom
+  (dream-catch-with (fn (req e) (dream-text (str "ERR:" e)))))
+(dream-er-test
+  "custom error page"
+  (dream-resp-body
+    ((dream-er-custom dream-er-boom) (dream-request "GET" "/" {} "")))
+  "ERR:kaboom")
+(dream-er-test
+  "custom passes normal through"
+  (dream-resp-body
+    ((dream-er-custom dream-er-ok) (dream-request "GET" "/" {} "")))
+  "fine")
+
+;; catch composes around a router
+(define
+  dream-er-app
+  (dream-catch
+    (dream-router
+      (list (dream-get "/boom" dream-er-boom) (dream-get "/ok" dream-er-ok)))))
+(dream-er-test
+  "router error caught"
+  (dream-status (dream-er-app (dream-request "GET" "/boom" {} "")))
+  500)
+(dream-er-test
+  "router ok intact"
+  (dream-resp-body (dream-er-app (dream-request "GET" "/ok" {} "")))
+  "fine")
+
+(define dream-er-tests-run! (fn () {:total (+ dream-er-pass dream-er-fail) :passed dream-er-pass :failed dream-er-fail :fails dream-er-fails}))

lib/dream/tests/flash.sx

@@ -0,0 +1,129 @@
+;; lib/dream/tests/flash.sx — codec + read-after-write across requests.
+
+(define dream-fl-pass 0)
+(define dream-fl-fail 0)
+(define dream-fl-fails (list))
+
+(define
+  dream-fl-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-fl-pass (+ dream-fl-pass 1))
+      (begin
+        (set! dream-fl-fail (+ dream-fl-fail 1))
+        (append! dream-fl-fails {:name name :actual actual :expected expected})))))
+
+;; ── codec ──────────────────────────────────────────────────────────
+(dream-fl-test "encode one" (dr/flash-encode (list {:message "saved" :category "info"})) "info|saved")
+(dream-fl-test
+  "encode two"
+  (dr/flash-encode (list {:message "a" :category "info"} {:message "b" :category "error"}))
+  "info|a~error|b")
+(dream-fl-test "decode one" (dr/flash-decode "info|saved") (list {:message "saved" :category "info"}))
+(dream-fl-test "decode empty" (dr/flash-decode "") (list))
+(dream-fl-test
+  "roundtrip special chars"
+  (dr/flash-decode (dr/flash-encode (list {:message "a~b%c" :category "x|y"})))
+  (list {:message "a~b%c" :category "x|y"}))
+(dream-fl-test "escape pipe" (dr/flash-encode (list {:message "a|b" :category "c"})) "c|a%7Cb")
+
+;; extract a cookie value from a Set-Cookie string
+(define
+  dream-fl-cookie-val
+  (fn
+    (setc)
+    (let
+      ((after (substr setc (+ (index-of setc "=") 1))))
+      (substr after 0 (index-of after ";")))))
+
+;; ── read-after-write across requests ───────────────────────────────
+(define
+  dream-fl-set-h
+  (fn
+    (req)
+    (begin (dream-add-flash-message req "info" "Saved!") (dream-text "done"))))
+(define dream-fl-set-app (dream-flash dream-fl-set-h))
+
+;; request 1: add a flash, no incoming -> sets the flash cookie
+(define
+  dream-fl-r1
+  (dream-fl-set-app (dream-request "POST" "/save" {} "")))
+(dream-fl-test "writer body" (dream-resp-body dream-fl-r1) "done")
+(dream-fl-test
+  "writer sets flash cookie"
+  (len (dream-resp-cookies dream-fl-r1))
+  1)
+(dream-fl-test
+  "writer has no incoming"
+  (dream-flash-messages
+    (assoc (dream-request "GET" "/" {} "") :dream-flash {:box (dr/flash-box) :incoming (list)}))
+  (list))
+
+;; request 2: carries the flash cookie -> handler reads it, cookie cleared
+(define
+  dream-fl-cval
+  (dream-fl-cookie-val (first (dream-resp-cookies dream-fl-r1))))
+(define
+  dream-fl-read-h
+  (fn
+    (req)
+    (let
+      ((msgs (dream-flash-messages req)))
+      (dream-text
+        (if (empty? msgs) "none" (dream-flash-message (first msgs)))))))
+(define dream-fl-read-app (dream-flash dream-fl-read-h))
+(define
+  dream-fl-r2
+  (dream-fl-read-app (dream-request "GET" "/" {:Cookie (str "dream.flash=" dream-fl-cval)} "")))
+(dream-fl-test "reader sees message" (dream-resp-body dream-fl-r2) "Saved!")
+(dream-fl-test
+  "reader clears cookie (Max-Age=0)"
+  (contains? (first (dream-resp-cookies dream-fl-r2)) "Max-Age=0")
+  true)
+
+;; request 3: no flash cookie -> nothing to read, no cookie set
+(define
+  dream-fl-r3
+  (dream-fl-read-app (dream-request "GET" "/" {} "")))
+(dream-fl-test "no flash -> none" (dream-resp-body dream-fl-r3) "none")
+(dream-fl-test
+  "no flash -> no cookie"
+  (len (dream-resp-cookies dream-fl-r3))
+  0)
+
+;; ── multiple categories ────────────────────────────────────────────
+(define
+  dream-fl-multi-h
+  (fn
+    (req)
+    (begin
+      (dream-add-flash-message req "info" "i1")
+      (dream-add-flash-message req "error" "e1")
+      (dream-add-flash-message req "info" "i2")
+      (dream-text "ok"))))
+(define
+  dream-fl-multi-r1
+  ((dream-flash dream-fl-multi-h) (dream-request "GET" "/" {} "")))
+(define
+  dream-fl-multi-val
+  (dream-fl-cookie-val (first (dream-resp-cookies dream-fl-multi-r1))))
+(define
+  dream-fl-count-h
+  (fn
+    (req)
+    (dream-text
+      (str
+        (len (dream-flash-messages req))
+        "/"
+        (len (dream-flash-of req "info"))))))
+(define
+  dream-fl-multi-r2
+  ((dream-flash dream-fl-count-h) (dream-request "GET" "/" {:Cookie (str "dream.flash=" dream-fl-multi-val)} "")))
+(dream-fl-test
+  "multi: all + filtered counts"
+  (dream-resp-body dream-fl-multi-r2)
+  "3/2")
+
+(define dream-fl-tests-run! (fn () {:total (+ dream-fl-pass dream-fl-fail) :passed dream-fl-pass :failed dream-fl-fail :fails dream-fl-fails}))

lib/dream/tests/form.sx

@@ -0,0 +1,226 @@
+;; lib/dream/tests/form.sx — urlencoded parsing, Ok/Err, CSRF accept/reject, multipart.
+
+(define dream-fo-pass 0)
+(define dream-fo-fail 0)
+(define dream-fo-fails (list))
+
+(define
+  dream-fo-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-fo-pass (+ dream-fo-pass 1))
+      (begin
+        (set! dream-fo-fail (+ dream-fo-fail 1))
+        (append! dream-fo-fails {:name name :actual actual :expected expected})))))
+
+;; ── Result ─────────────────────────────────────────────────────────
+(dream-fo-test "ok? on ok" (dream-ok? (dream-ok 5)) true)
+(dream-fo-test "err? on ok" (dream-err? (dream-ok 5)) false)
+(dream-fo-test "ok value" (dream-ok-value (dream-ok {:a 1})) {:a 1})
+(dream-fo-test "err reason" (dream-err-reason (dream-err :bad)) "bad")
+
+;; ── urlencoded parsing ─────────────────────────────────────────────
+(define
+  dream-fo-req
+  (fn (body) (dream-request "POST" "/f" {:Content-Type "application/x-www-form-urlencoded"} body)))
+
+(dream-fo-test
+  "parse two fields"
+  (dream-form-fields (dream-fo-req "a=1&b=2"))
+  {:a "1" :b "2"})
+(dream-fo-test
+  "url-decoded value"
+  (dream-form-field (dream-fo-req "name=Ada+Lovelace") "name")
+  "Ada Lovelace")
+(dream-fo-test
+  "percent decode"
+  (dream-form-field (dream-fo-req "x=a%20b%21") "x")
+  "a b!")
+(dream-fo-test "empty body" (dream-form-fields (dream-fo-req "")) {})
+(dream-fo-test
+  "valueless key"
+  (dream-form-field (dream-fo-req "flag") "flag")
+  "")
+(dream-fo-test
+  "decoded key"
+  (dream-form-field (dream-fo-req "first%20name=x") "first name")
+  "x")
+
+;; ── CSRF sign + verify ─────────────────────────────────────────────
+(dream-fo-test
+  "sign deterministic"
+  (=
+    (dream-csrf-sign-default "secret" "s1")
+    (dream-csrf-sign-default "secret" "s1"))
+  true)
+(dream-fo-test
+  "sign secret-sensitive"
+  (=
+    (dream-csrf-sign-default "secret" "s1")
+    (dream-csrf-sign-default "other" "s1"))
+  false)
+(dream-fo-test
+  "sign session-sensitive"
+  (=
+    (dream-csrf-sign-default "secret" "s1")
+    (dream-csrf-sign-default "secret" "s2"))
+  false)
+(dream-fo-test
+  "token valid for own session"
+  (dr/csrf-valid?
+    dream-csrf-sign-default
+    "k"
+    "s1"
+    (dr/csrf-make-token dream-csrf-sign-default "k" "s1"))
+  true)
+(dream-fo-test
+  "token invalid for other session"
+  (dr/csrf-valid?
+    dream-csrf-sign-default
+    "k"
+    "s2"
+    (dr/csrf-make-token dream-csrf-sign-default "k" "s1"))
+  false)
+(dream-fo-test
+  "tampered token invalid"
+  (dr/csrf-valid? dream-csrf-sign-default "k" "s1" "s1.deadbeef")
+  false)
+(dream-fo-test
+  "empty token invalid"
+  (dr/csrf-valid? dream-csrf-sign-default "k" "s1" "")
+  false)
+(dream-fo-test
+  "nil token invalid"
+  (dr/csrf-valid? dream-csrf-sign-default "k" "s1" nil)
+  false)
+
+;; ── full stack: session -> csrf -> handler ─────────────────────────
+(define dream-fo-backend (dream-memory-sessions))
+(define dream-fo-sid (dream-fo-backend {:op "session/create"}))   ;; s1
+
+(define
+  dream-fo-stack
+  (fn
+    (handler)
+    ((dream-sessions dream-fo-backend) ((dream-csrf "topsecret") handler))))
+
+(define
+  dream-fo-tag-out
+  (dream-resp-body
+    ((dream-fo-stack (fn (req) (dream-text (dream-csrf-tag req))))
+      (dream-request "GET" "/form" {:Cookie "dream.session=s1"} ""))))
+(dream-fo-test
+  "csrf-tag is hidden input"
+  (contains? dream-fo-tag-out "type=\"hidden\"")
+  true)
+(dream-fo-test
+  "csrf-tag names field"
+  (contains? dream-fo-tag-out "name=\"dream.csrf\"")
+  true)
+
+(define
+  dream-fo-good-token
+  (dr/csrf-make-token dream-csrf-sign-default "topsecret" "s1"))
+(define
+  dream-fo-submit
+  (fn
+    (token)
+    ((dream-fo-stack (fn (req) (let ((r (dream-form req))) (if (dream-ok? r) (dream-text (str "ok:" (get (dream-ok-value r) "msg"))) (dream-text (str "err:" (dream-err-reason r)))))))
+      (dream-request
+        "POST"
+        "/form"
+        {:Cookie "dream.session=s1"}
+        (str "msg=hello&dream.csrf=" token)))))
+
+(dream-fo-test
+  "valid csrf -> Ok fields"
+  (dream-resp-body (dream-fo-submit dream-fo-good-token))
+  "ok:hello")
+(dream-fo-test
+  "bad csrf -> Err"
+  (dream-resp-body (dream-fo-submit "s1.wrong"))
+  "err:csrf-token-invalid")
+(dream-fo-test
+  "missing csrf -> Err"
+  (dream-resp-body (dream-fo-submit ""))
+  "err:csrf-token-invalid")
+
+;; ── csrf-protect middleware auto-rejects ───────────────────────────
+(define
+  dream-fo-protected
+  (fn
+    (handler)
+    ((dream-sessions dream-fo-backend)
+      ((dream-csrf-protect "topsecret") handler))))
+(define dream-fo-ph (dream-fo-protected (fn (req) (dream-text "reached"))))
+
+(dream-fo-test
+  "GET passes without token"
+  (dream-resp-body (dream-fo-ph (dream-request "GET" "/x" {:Cookie "dream.session=s1"} "")))
+  "reached")
+(dream-fo-test
+  "POST without token 403"
+  (dream-status (dream-fo-ph (dream-request "POST" "/x" {:Cookie "dream.session=s1"} "")))
+  403)
+(dream-fo-test
+  "POST with valid token reaches"
+  (dream-resp-body
+    (dream-fo-ph
+      (dream-request
+        "POST"
+        "/x"
+        {:Cookie "dream.session=s1"}
+        (str "dream.csrf=" dream-fo-good-token))))
+  "reached")
+
+;; ── multipart/form-data ────────────────────────────────────────────
+(define
+  dream-fo-mp-body
+  (str
+    "--B1\r\n"
+    "Content-Disposition: form-data; name=\"title\"\r\n\r\n"
+    "Hello\r\n"
+    "--B1\r\n"
+    "Content-Disposition: form-data; name=\"file\"; filename=\"a.txt\"\r\nContent-Type: text/plain\r\n\r\n"
+    "line1\r\nline2\r\n"
+    "--B1--\r\n"))
+(define
+  dream-fo-mp-req
+  (dream-request "POST" "/upload" {:Content-Type "multipart/form-data; boundary=B1"} dream-fo-mp-body))
+(define dream-fo-mp (dream-multipart dream-fo-mp-req))
+(dream-fo-test "multipart is Ok" (dream-ok? dream-fo-mp) true)
+(define dream-fo-parts (dream-ok-value dream-fo-mp))
+(dream-fo-test "two parts" (len dream-fo-parts) 2)
+(dream-fo-test
+  "field value"
+  (dream-multipart-field dream-fo-parts "title")
+  "Hello")
+(dream-fo-test
+  "file part filename"
+  (get (dream-multipart-file dream-fo-parts "file") :filename)
+  "a.txt")
+(dream-fo-test
+  "file content-type"
+  (get (dream-multipart-file dream-fo-parts "file") :content-type)
+  "text/plain")
+(dream-fo-test
+  "file content keeps inner CRLF"
+  (get (dream-multipart-file dream-fo-parts "file") :content)
+  "line1\r\nline2")
+(dream-fo-test
+  "field is not a file"
+  (get (dream-multipart-file dream-fo-parts "title") :filename)
+  nil)
+(dream-fo-test
+  "non-multipart is Err"
+  (dream-err? (dream-multipart (dream-request "POST" "/x" {:Content-Type "text/plain"} "hi")))
+  true)
+(dream-fo-test
+  "quoted boundary parsed"
+  (dream-ok?
+    (dream-multipart (dream-request "POST" "/u" {:Content-Type "multipart/form-data; boundary=\"B1\""} dream-fo-mp-body)))
+  true)
+
+(define dream-fo-tests-run! (fn () {:total (+ dream-fo-pass dream-fo-fail) :passed dream-fo-pass :failed dream-fo-fail :fails dream-fo-fails}))

lib/dream/tests/headers.sx

@@ -0,0 +1,94 @@
+;; lib/dream/tests/headers.sx — security headers + cache-control.
+
+(define dream-hd-pass 0)
+(define dream-hd-fail 0)
+(define dream-hd-fails (list))
+
+(define
+  dream-hd-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-hd-pass (+ dream-hd-pass 1))
+      (begin
+        (set! dream-hd-fail (+ dream-hd-fail 1))
+        (append! dream-hd-fails {:name name :actual actual :expected expected})))))
+
+(define dream-hd-h (fn (req) (dream-text "body")))
+(define dream-hd-req (dream-request "GET" "/" {} ""))
+
+;; ── security headers ───────────────────────────────────────────────
+(define dream-hd-sec ((dream-security-headers dream-hd-h) dream-hd-req))
+(dream-hd-test
+  "nosniff"
+  (dream-resp-header dream-hd-sec "x-content-type-options")
+  "nosniff")
+(dream-hd-test
+  "frame deny"
+  (dream-resp-header dream-hd-sec "x-frame-options")
+  "DENY")
+(dream-hd-test
+  "referrer policy"
+  (dream-resp-header dream-hd-sec "referrer-policy")
+  "no-referrer")
+(dream-hd-test
+  "no hsts by default"
+  (dream-resp-header dream-hd-sec "strict-transport-security")
+  nil)
+(dream-hd-test "body preserved" (dream-resp-body dream-hd-sec) "body")
+
+(define
+  dream-hd-hsts
+  ((dream-security-headers-with (assoc dream-security-defaults :hsts true))
+    dream-hd-h))
+(dream-hd-test
+  "hsts when enabled"
+  (contains?
+    (dream-resp-header
+      (dream-hd-hsts dream-hd-req)
+      "strict-transport-security")
+    "max-age=31536000")
+  true)
+
+;; ── cache-control ──────────────────────────────────────────────────
+(dream-hd-test
+  "cache public"
+  (dream-resp-header
+    (dream-cache (dream-text "x") 60)
+    "cache-control")
+  "public, max-age=60")
+(dream-hd-test
+  "private cache"
+  (dream-resp-header
+    (dream-private-cache (dream-text "x") 30)
+    "cache-control")
+  "private, max-age=30")
+(dream-hd-test
+  "no-store"
+  (dream-resp-header (dream-no-store (dream-text "x")) "cache-control")
+  "no-store")
+(dream-hd-test
+  "no-cache"
+  (dream-resp-header (dream-no-cache (dream-text "x")) "cache-control")
+  "no-cache, no-store, must-revalidate")
+
+;; ── cache middleware ───────────────────────────────────────────────
+(define dream-hd-capp ((dream-cache-for 300) dream-hd-h))
+(dream-hd-test
+  "cache-for stamps"
+  (dream-resp-header (dream-hd-capp dream-hd-req) "cache-control")
+  "public, max-age=300")
+
+;; ── composes around a router ───────────────────────────────────────
+(define
+  dream-hd-app
+  (dream-security-headers
+    (dream-router
+      (list (dream-get "/" (fn (req) (dream-html "<p>hi</p>")))))))
+(dream-hd-test
+  "router security header"
+  (dream-resp-header (dream-hd-app dream-hd-req) "x-frame-options")
+  "DENY")
+
+(define dream-hd-tests-run! (fn () {:total (+ dream-hd-pass dream-hd-fail) :passed dream-hd-pass :failed dream-hd-fail :fails dream-hd-fails}))

lib/dream/tests/html.sx

@@ -0,0 +1,59 @@
+;; lib/dream/tests/html.sx — HTML escaping (+ demo XSS regression).
+
+(define dream-ht-pass 0)
+(define dream-ht-fail 0)
+(define dream-ht-fails (list))
+
+(define
+  dream-ht-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-ht-pass (+ dream-ht-pass 1))
+      (begin
+        (set! dream-ht-fail (+ dream-ht-fail 1))
+        (append! dream-ht-fails {:name name :actual actual :expected expected})))))
+
+(dream-ht-test "escape ampersand" (dream-escape "a & b") "a & b")
+(dream-ht-test "escape lt gt" (dream-escape "<b>") "&lt;b&gt;")
+(dream-ht-test "escape quote" (dream-escape "say \"hi\"") "say &quot;hi&quot;")
+(dream-ht-test "escape apostrophe" (dream-escape "it's") "it&#39;s")
+(dream-ht-test
+  "escape script tag"
+  (dream-escape "<script>alert(1)</script>")
+  "&lt;script&gt;alert(1)&lt;/script&gt;")
+(dream-ht-test
+  "ampersand first (no double-escape)"
+  (dream-escape "&lt;")
+  "&amp;lt;")
+(dream-ht-test
+  "safe string unchanged"
+  (dream-escape "hello world")
+  "hello world")
+(dream-ht-test
+  "attr escapes value"
+  (dream-attr "title" "a\"b")
+  "title=\"a&quot;b\"")
+(dream-ht-test
+  "escape-join"
+  (dream-escape-join " " (list "<a>" "<b>"))
+  "&lt;a&gt; &lt;b&gt;")
+
+;; ── todo demo escapes user input (XSS regression) ──────────────────
+(define dream-ht-store (dream-todo-store))
+((get dream-ht-store :add) "<script>alert(1)</script>")
+(define
+  dream-ht-ctx
+  (assoc (dream-request "GET" "/" {} "") :dream-csrf {:sign dream-csrf-sign-default :sid "s1" :secret "k"}))
+(define dream-ht-rendered (dr/todo-render dream-ht-store dream-ht-ctx))
+(dream-ht-test
+  "todo escapes script"
+  (contains? dream-ht-rendered "&lt;script&gt;")
+  true)
+(dream-ht-test
+  "todo has no raw script"
+  (contains? dream-ht-rendered "<script>")
+  false)
+
+(define dream-ht-tests-run! (fn () {:total (+ dream-ht-pass dream-ht-fail) :passed dream-ht-pass :failed dream-ht-fail :fails dream-ht-fails}))

lib/dream/tests/json.sx

@@ -0,0 +1,105 @@
+;; lib/dream/tests/json.sx — JSON encode/parse round-trips.
+
+(define dream-js-pass 0)
+(define dream-js-fail 0)
+(define dream-js-fails (list))
+
+(define
+  dream-js-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-js-pass (+ dream-js-pass 1))
+      (begin
+        (set! dream-js-fail (+ dream-js-fail 1))
+        (append! dream-js-fails {:name name :actual actual :expected expected})))))
+
+;; ── encoding scalars ───────────────────────────────────────────────
+(dream-js-test "encode int" (dream-json-encode 42) "42")
+(dream-js-test "encode float" (dream-json-encode 1.5) "1.5")
+(dream-js-test "encode true" (dream-json-encode true) "true")
+(dream-js-test "encode false" (dream-json-encode false) "false")
+(dream-js-test "encode nil" (dream-json-encode nil) "null")
+(dream-js-test "encode string" (dream-json-encode "hi") "\"hi\"")
+(dream-js-test
+  "encode string escapes quote"
+  (dream-json-encode "a\"b")
+  "\"a\\\"b\"")
+(dream-js-test
+  "encode list"
+  (dream-json-encode (list 1 2 3))
+  "[1,2,3]")
+(dream-js-test
+  "encode list of strings"
+  (dream-json-encode (list "a" "b"))
+  "[\"a\",\"b\"]")
+(dream-js-test
+  "encode single-key dict"
+  (dream-json-encode {:a 1})
+  "{\"a\":1}")
+(dream-js-test "encode empty list" (dream-json-encode (list)) "[]")
+(dream-js-test "encode empty dict" (dream-json-encode {}) "{}")
+
+;; ── parsing scalars ────────────────────────────────────────────────
+(dream-js-test "parse int" (dream-json-parse "5") 5)
+(dream-js-test "parse negative" (dream-json-parse "-7") -7)
+(dream-js-test "parse float" (dream-json-parse "1.5") 1.5)
+(dream-js-test "parse true" (dream-json-parse "true") true)
+(dream-js-test "parse false" (dream-json-parse "false") false)
+(dream-js-test "parse null" (dream-json-parse "null") nil)
+(dream-js-test "parse string" (dream-json-parse "\"hello\"") "hello")
+(dream-js-test "parse string escape" (dream-json-parse "\"a\\nb\"") "a\nb")
+(dream-js-test
+  "parse array"
+  (dream-json-parse "[1,2,3]")
+  (list 1 2 3))
+(dream-js-test "parse empty array" (dream-json-parse "[]") (list))
+(dream-js-test
+  "parse with whitespace"
+  (dream-json-parse "  [ 1 , 2 ]  ")
+  (list 1 2))
+
+;; ── parsing objects ────────────────────────────────────────────────
+(define dream-js-obj (dream-json-parse "{\"x\":5,\"y\":\"hi\"}"))
+(dream-js-test "parse obj number" (get dream-js-obj "x") 5)
+(dream-js-test "parse obj string" (get dream-js-obj "y") "hi")
+(dream-js-test "parse empty obj" (dream-json-parse "{}") {})
+
+;; ── nested ─────────────────────────────────────────────────────────
+(define dream-js-nested (dream-json-parse "{\"a\":[1,{\"b\":2}],\"c\":true}"))
+(dream-js-test
+  "nested array first"
+  (first (get dream-js-nested "a"))
+  1)
+(dream-js-test
+  "nested object in array"
+  (get (nth (get dream-js-nested "a") 1) "b")
+  2)
+(dream-js-test "nested bool" (get dream-js-nested "c") true)
+
+;; ── round-trips ────────────────────────────────────────────────────
+(define dream-js-v {:name "Ada" :age 36 :tags (list "math" "engine")})
+(define dream-js-rt (dream-json-parse (dream-json-encode dream-js-v)))
+(dream-js-test "roundtrip name" (get dream-js-rt "name") "Ada")
+(dream-js-test "roundtrip age" (get dream-js-rt "age") 36)
+(dream-js-test
+  "roundtrip tags"
+  (get dream-js-rt "tags")
+  (list "math" "engine"))
+
+;; ── response + request helpers ─────────────────────────────────────
+(dream-js-test
+  "json-value content-type"
+  (dream-resp-header (dream-json-value {:ok true}) "content-type")
+  "application/json")
+(dream-js-test
+  "json-value body"
+  (dream-resp-body (dream-json-value {:ok true}))
+  "{\"ok\":true}")
+(dream-js-test
+  "json-body parses request"
+  (get (dream-json-body (dream-request "POST" "/" {} "{\"n\":9}")) "n")
+  9)
+
+(define dream-js-tests-run! (fn () {:total (+ dream-js-pass dream-js-fail) :passed dream-js-pass :failed dream-js-fail :fails dream-js-fails}))

lib/dream/tests/middleware.sx

@@ -0,0 +1,150 @@
+;; lib/dream/tests/middleware.sx — composition, logger, content-type sniffer.
+
+(define dream-mw-pass 0)
+(define dream-mw-fail 0)
+(define dream-mw-fails (list))
+
+(define
+  dream-mw-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-mw-pass (+ dream-mw-pass 1))
+      (begin
+        (set! dream-mw-fail (+ dream-mw-fail 1))
+        (append! dream-mw-fails {:name name :actual actual :expected expected})))))
+
+(define dream-mw-req (dream-request "GET" "/p" {} ""))
+
+;; ── pipeline composition order ─────────────────────────────────────
+(define
+  dream-mw-wrap
+  (fn
+    (tag)
+    (fn
+      (next)
+      (fn
+        (req)
+        (dream-html (str tag "(" (dream-resp-body (next req)) ")"))))))
+(define dream-mw-h (fn (req) (dream-html "h")))
+
+(dream-mw-test
+  "pipeline empty is identity"
+  (dream-resp-body ((dream-pipeline (list) dream-mw-h) dream-mw-req))
+  "h")
+(dream-mw-test
+  "pipeline single"
+  (dream-resp-body
+    ((dream-pipeline (list (dream-mw-wrap "a")) dream-mw-h) dream-mw-req))
+  "a(h)")
+(dream-mw-test
+  "pipeline first is outermost"
+  (dream-resp-body
+    ((dream-pipeline (list (dream-mw-wrap "a") (dream-mw-wrap "b")) dream-mw-h)
+      dream-mw-req))
+  "a(b(h))")
+(dream-mw-test
+  "no-middleware is identity"
+  (dream-resp-body ((dream-no-middleware dream-mw-h) dream-mw-req))
+  "h")
+
+;; ── logger ─────────────────────────────────────────────────────────
+(define dream-mw-clock-n 0)
+(define
+  dream-mw-clock
+  (fn
+    ()
+    (begin
+      (set! dream-mw-clock-n (+ dream-mw-clock-n 1))
+      dream-mw-clock-n)))
+(define dream-mw-entries (list))
+(define dream-mw-sink (fn (e) (append! dream-mw-entries e)))
+(define
+  dream-mw-logged
+  ((dream-logger-with dream-mw-clock dream-mw-sink)
+    (fn (req) (dream-html-status 201 "ok"))))
+(define
+  dream-mw-lresp
+  (dream-mw-logged (dream-request "POST" "/log/path" {} "")))
+
+(dream-mw-test
+  "logger passes response through"
+  (dream-resp-body dream-mw-lresp)
+  "ok")
+(dream-mw-test "logger records one entry" (len dream-mw-entries) 1)
+(dream-mw-test
+  "logger entry method"
+  (get (first dream-mw-entries) :method)
+  "POST")
+(dream-mw-test
+  "logger entry path"
+  (get (first dream-mw-entries) :path)
+  "/log/path")
+(dream-mw-test
+  "logger entry status"
+  (get (first dream-mw-entries) :status)
+  201)
+(dream-mw-test
+  "logger entry elapsed"
+  (get (first dream-mw-entries) :elapsed)
+  1)
+(dream-mw-test
+  "log-line format"
+  (dream-log-line {:path "/x" :status 200 :method "GET" :elapsed 4})
+  "GET /x -> 200 (4ms)")
+
+;; ── content-type sniffer ───────────────────────────────────────────
+(define dream-mw-ct (fn (handler) (dream-content-type handler)))
+(define
+  dream-mw-sniff
+  (fn
+    (body)
+    (dream-resp-header
+      ((dream-content-type (fn (req) (dream-response 200 {} body)))
+        dream-mw-req)
+      "content-type")))
+
+(dream-mw-test
+  "sniff html"
+  (dream-mw-sniff "<p>hi</p>")
+  "text/html; charset=utf-8")
+(dream-mw-test
+  "sniff doctype"
+  (dream-mw-sniff "<!doctype html>")
+  "text/html; charset=utf-8")
+(dream-mw-test
+  "sniff json object"
+  (dream-mw-sniff "{\"a\":1}")
+  "application/json")
+(dream-mw-test "sniff json array" (dream-mw-sniff "[1,2]") "application/json")
+(dream-mw-test
+  "sniff plain text"
+  (dream-mw-sniff "just words")
+  "text/plain; charset=utf-8")
+(dream-mw-test
+  "sniff empty body"
+  (dream-mw-sniff "")
+  "text/plain; charset=utf-8")
+(dream-mw-test
+  "sniff does not override existing"
+  (dream-resp-header
+    ((dream-content-type (fn (req) (dream-json "{}"))) dream-mw-req)
+    "content-type")
+  "application/json")
+
+;; ── small middlewares ──────────────────────────────────────────────
+(dream-mw-test
+  "set-header attaches"
+  (dream-resp-header
+    (((dream-set-header "X-A" "1") dream-mw-h) dream-mw-req)
+    "x-a")
+  "1")
+(dream-mw-test
+  "tap-request rewrites"
+  (dream-resp-body
+    (((dream-tap-request (fn (req) (dream-set-body req "tapped"))) (fn (req) (dream-html (dream-body req))))
+      (dream-request "GET" "/" {} "orig")))
+  "tapped")
+
+(define dream-mw-tests-run! (fn () {:total (+ dream-mw-pass dream-mw-fail) :passed dream-mw-pass :failed dream-mw-fail :fails dream-mw-fails}))

lib/dream/tests/router.sx

@@ -0,0 +1,272 @@
+;; lib/dream/tests/router.sx — routing dispatch, path params, scopes, 405/HEAD.
+
+(define dream-rt-pass 0)
+(define dream-rt-fail 0)
+(define dream-rt-fails (list))
+
+(define
+  dream-rt-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-rt-pass (+ dream-rt-pass 1))
+      (begin
+        (set! dream-rt-fail (+ dream-rt-fail 1))
+        (append! dream-rt-fails {:name name :actual actual :expected expected})))))
+
+(define
+  dream-rt-req
+  (fn (method target) (dream-request method target {} "")))
+
+;; ── basic dispatch ─────────────────────────────────────────────────
+(define
+  dream-rt-app
+  (dream-router
+    (list
+      (dream-get "/" (fn (req) (dream-text "home")))
+      (dream-get "/about" (fn (req) (dream-text "about")))
+      (dream-post "/submit" (fn (req) (dream-text "posted"))))))
+
+(dream-rt-test
+  "GET / -> home"
+  (dream-resp-body (dream-rt-app (dream-rt-req "GET" "/")))
+  "home")
+(dream-rt-test
+  "GET /about"
+  (dream-resp-body (dream-rt-app (dream-rt-req "GET" "/about")))
+  "about")
+(dream-rt-test
+  "POST /submit"
+  (dream-resp-body (dream-rt-app (dream-rt-req "POST" "/submit")))
+  "posted")
+(dream-rt-test
+  "unknown path 404"
+  (dream-status (dream-rt-app (dream-rt-req "GET" "/nope")))
+  404)
+(dream-rt-test
+  "wrong method 405"
+  (dream-status (dream-rt-app (dream-rt-req "GET" "/submit")))
+  405)
+(dream-rt-test
+  "trailing slash equiv"
+  (dream-resp-body (dream-rt-app (dream-rt-req "GET" "/about/")))
+  "about")
+(dream-rt-test
+  "query ignored for routing"
+  (dream-resp-body (dream-rt-app (dream-rt-req "GET" "/about?x=1")))
+  "about")
+
+;; ── path params ────────────────────────────────────────────────────
+(define
+  dream-rt-papp
+  (dream-router
+    (list
+      (dream-get
+        "/users/:id"
+        (fn (req) (dream-text (dream-param req "id"))))
+      (dream-get
+        "/users/:id/posts/:pid"
+        (fn
+          (req)
+          (dream-text
+            (str (dream-param req "id") "-" (dream-param req "pid")))))
+      (dream-get
+        "/files/**"
+        (fn (req) (dream-text (dream-param req "**")))))))
+
+(dream-rt-test
+  "single param"
+  (dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/users/42")))
+  "42")
+(dream-rt-test
+  "two params"
+  (dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/users/7/posts/9")))
+  "7-9")
+(dream-rt-test
+  "param no over-match"
+  (dream-status (dream-rt-papp (dream-rt-req "GET" "/users/7/extra")))
+  404)
+(dream-rt-test
+  "catch-all captures rest"
+  (dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/files/a/b/c.txt")))
+  "a/b/c.txt")
+(dream-rt-test
+  "catch-all empty rest"
+  (dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/files/")))
+  "")
+
+;; ── route order: first match wins ──────────────────────────────────
+(define
+  dream-rt-order
+  (dream-router
+    (list
+      (dream-get "/x/specific" (fn (req) (dream-text "specific")))
+      (dream-get "/x/:slug" (fn (req) (dream-text "generic"))))))
+(dream-rt-test
+  "first match wins"
+  (dream-resp-body (dream-rt-order (dream-rt-req "GET" "/x/specific")))
+  "specific")
+(dream-rt-test
+  "fallthrough to param"
+  (dream-resp-body (dream-rt-order (dream-rt-req "GET" "/x/other")))
+  "generic")
+
+;; ── ANY method ─────────────────────────────────────────────────────
+(define
+  dream-rt-any
+  (dream-router
+    (list (dream-any "/ping" (fn (req) (dream-text (dream-method req)))))))
+(dream-rt-test
+  "ANY matches GET"
+  (dream-resp-body (dream-rt-any (dream-rt-req "GET" "/ping")))
+  "GET")
+(dream-rt-test
+  "ANY matches DELETE"
+  (dream-resp-body (dream-rt-any (dream-rt-req "DELETE" "/ping")))
+  "DELETE")
+
+;; ── handler returns bare string (coerced) ──────────────────────────
+(define
+  dream-rt-coerce
+  (dream-router (list (dream-get "/s" (fn (req) "bare")))))
+(dream-rt-test
+  "string coerced to 200"
+  (dream-status (dream-rt-coerce (dream-rt-req "GET" "/s")))
+  200)
+(dream-rt-test
+  "string coerced body"
+  (dream-resp-body (dream-rt-coerce (dream-rt-req "GET" "/s")))
+  "bare")
+
+;; ── scope: prefix mount ────────────────────────────────────────────
+(define
+  dream-rt-scoped
+  (dream-router
+    (list
+      (dream-get "/" (fn (req) (dream-text "root")))
+      (dream-scope
+        "/api"
+        (list)
+        (list
+          (dream-get "/users" (fn (req) (dream-text "api-users")))
+          (dream-get
+            "/users/:id"
+            (fn
+              (req)
+              (dream-text (str "api-user-" (dream-param req "id"))))))))))
+(dream-rt-test
+  "scope root still works"
+  (dream-resp-body (dream-rt-scoped (dream-rt-req "GET" "/")))
+  "root")
+(dream-rt-test
+  "scope prefix path"
+  (dream-resp-body (dream-rt-scoped (dream-rt-req "GET" "/api/users")))
+  "api-users")
+(dream-rt-test
+  "scope prefix param"
+  (dream-resp-body (dream-rt-scoped (dream-rt-req "GET" "/api/users/5")))
+  "api-user-5")
+(dream-rt-test
+  "scope unprefixed 404"
+  (dream-status (dream-rt-scoped (dream-rt-req "GET" "/users")))
+  404)
+
+;; ── scope: middleware applied to all routes ────────────────────────
+(define
+  dream-rt-mw
+  (fn (next) (fn (req) (dream-add-header (next req) "X-Scope" "on"))))
+(define
+  dream-rt-mwapp
+  (dream-router
+    (list
+      (dream-scope
+        "/v1"
+        (list dream-rt-mw)
+        (list (dream-get "/a" (fn (req) (dream-text "a"))))))))
+(dream-rt-test
+  "scope mw header"
+  (dream-resp-header (dream-rt-mwapp (dream-rt-req "GET" "/v1/a")) "x-scope")
+  "on")
+(dream-rt-test
+  "scope mw body intact"
+  (dream-resp-body (dream-rt-mwapp (dream-rt-req "GET" "/v1/a")))
+  "a")
+
+;; ── nested scopes ──────────────────────────────────────────────────
+(define
+  dream-rt-outer
+  (fn (next) (fn (req) (dream-add-header (next req) "X-Outer" "1"))))
+(define
+  dream-rt-inner
+  (fn (next) (fn (req) (dream-add-header (next req) "X-Inner" "1"))))
+(define
+  dream-rt-nested
+  (dream-router
+    (list
+      (dream-scope
+        "/api"
+        (list dream-rt-outer)
+        (list
+          (dream-scope
+            "/v2"
+            (list dream-rt-inner)
+            (list (dream-get "/thing" (fn (req) (dream-text "thing"))))))))))
+(dream-rt-test
+  "nested path"
+  (dream-resp-body (dream-rt-nested (dream-rt-req "GET" "/api/v2/thing")))
+  "thing")
+(dream-rt-test
+  "nested outer mw"
+  (dream-resp-header
+    (dream-rt-nested (dream-rt-req "GET" "/api/v2/thing"))
+    "x-outer")
+  "1")
+(dream-rt-test
+  "nested inner mw"
+  (dream-resp-header
+    (dream-rt-nested (dream-rt-req "GET" "/api/v2/thing"))
+    "x-inner")
+  "1")
+
+;; ── 405 Method Not Allowed + Allow ─────────────────────────────────
+(define
+  dream-rt-mapp
+  (dream-router
+    (list
+      (dream-get "/r" (fn (req) (dream-text "get")))
+      (dream-post "/r" (fn (req) (dream-text "post")))
+      (dream-get "/only" (fn (req) (dream-html "<p>hi</p>"))))))
+(define dream-rt-405 (dream-rt-mapp (dream-rt-req "DELETE" "/r")))
+(dream-rt-test "405 status" (dream-status dream-rt-405) 405)
+(dream-rt-test
+  "405 Allow has GET"
+  (contains? (dream-resp-header dream-rt-405 "allow") "GET")
+  true)
+(dream-rt-test
+  "405 Allow has POST"
+  (contains? (dream-resp-header dream-rt-405 "allow") "POST")
+  true)
+(dream-rt-test
+  "matching method still works"
+  (dream-resp-body (dream-rt-mapp (dream-rt-req "POST" "/r")))
+  "post")
+(dream-rt-test
+  "no path is 404 not 405"
+  (dream-status (dream-rt-mapp (dream-rt-req "DELETE" "/absent")))
+  404)
+
+;; ── automatic HEAD (serve GET, empty body) ─────────────────────────
+(define dream-rt-head (dream-rt-mapp (dream-rt-req "HEAD" "/only")))
+(dream-rt-test "HEAD status 200" (dream-status dream-rt-head) 200)
+(dream-rt-test "HEAD empty body" (dream-resp-body dream-rt-head) "")
+(dream-rt-test
+  "HEAD keeps content-type"
+  (dream-resp-header dream-rt-head "content-type")
+  "text/html; charset=utf-8")
+(dream-rt-test
+  "HEAD on missing path 404"
+  (dream-status (dream-rt-mapp (dream-rt-req "HEAD" "/none")))
+  404)
+
+(define dream-rt-tests-run! (fn () {:total (+ dream-rt-pass dream-rt-fail) :passed dream-rt-pass :failed dream-rt-fail :fails dream-rt-fails}))

lib/dream/tests/run.sx

@@ -0,0 +1,123 @@
+;; lib/dream/tests/run.sx — app adapter + dream-run wiring.
+
+(define dream-rn-pass 0)
+(define dream-rn-fail 0)
+(define dream-rn-fails (list))
+
+(define
+  dream-rn-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-rn-pass (+ dream-rn-pass 1))
+      (begin
+        (set! dream-rn-fail (+ dream-rn-fail 1))
+        (append! dream-rn-fails {:name name :actual actual :expected expected})))))
+
+;; ── app adapter: raw -> serialised response ────────────────────────
+(define
+  dream-rn-router
+  (dream-router
+    (list
+      (dream-get "/" (fn (req) (dream-text "home")))
+      (dream-get
+        "/u/:id"
+        (fn (req) (dream-text (str "u=" (dream-param req "id")))))
+      (dream-post "/echo" (fn (req) (dream-text (dream-body req)))))))
+(define dream-rn-app (dream-app dream-rn-router))
+
+(define dream-rn-r1 (dream-rn-app {:method "GET" :target "/"}))
+(dream-rn-test "serialised status" (get dream-rn-r1 :status) 200)
+(dream-rn-test "serialised body" (get dream-rn-r1 :body) "home")
+(dream-rn-test
+  "serialised content-type"
+  (get (get dream-rn-r1 :headers) "content-type")
+  "text/plain; charset=utf-8")
+(dream-rn-test
+  "serialised set-cookies empty"
+  (get dream-rn-r1 :set-cookies)
+  (list))
+
+(dream-rn-test
+  "adapts target+params"
+  (get (dream-rn-app {:method "GET" :target "/u/42"}) :body)
+  "u=42")
+(dream-rn-test "adapts body" (get (dream-rn-app {:body "ping" :method "POST" :target "/echo"}) :body) "ping")
+(dream-rn-test
+  "method defaults to GET"
+  (get (dream-rn-app {:target "/"}) :body)
+  "home")
+(dream-rn-test
+  "missing target -> /"
+  (get (dream-rn-app {:method "GET"}) :status)
+  200)
+(dream-rn-test
+  "unknown route 404"
+  (get (dream-rn-app {:method "GET" :target "/nope"}) :status)
+  404)
+
+;; bare-string handler is coerced
+(define dream-rn-bare (dream-app (fn (req) "plain")))
+(dream-rn-test
+  "coerces bare string status"
+  (get (dream-rn-bare {:target "/"}) :status)
+  200)
+(dream-rn-test
+  "coerces bare string body"
+  (get (dream-rn-bare {:target "/"}) :body)
+  "plain")
+
+;; ── set-cookies flow through (session middleware) ──────────────────
+(define
+  dream-rn-sess-app
+  (dream-app
+    ((dream-sessions (dream-memory-sessions))
+      (fn (req) (dream-text "ok")))))
+(define dream-rn-sess-r (dream-rn-sess-app {:method "GET" :target "/"}))
+(dream-rn-test
+  "session set-cookie present"
+  (len (get dream-rn-sess-r :set-cookies))
+  1)
+(dream-rn-test
+  "session cookie content"
+  (contains? (first (get dream-rn-sess-r :set-cookies)) "dream.session=")
+  true)
+
+;; ── websocket upgrade serialisation ────────────────────────────────
+(define
+  dream-rn-ws-app
+  (dream-app (dream-websocket (fn (ws) (dream-close ws)))))
+(define dream-rn-ws-r (dream-rn-ws-app {:method "GET" :target "/ws"}))
+(dream-rn-test "ws upgrade status 101" (get dream-rn-ws-r :status) 101)
+(dream-rn-test
+  "ws handler carried"
+  (not (nil? (get dream-rn-ws-r :websocket)))
+  true)
+
+;; ── dream-run wiring (mock listen captures the op) ─────────────────
+(define dream-rn-captured nil)
+(define
+  dream-rn-listen
+  (fn (op) (begin (set! dream-rn-captured op) :listening)))
+(define
+  dream-rn-result
+  (dream-run-with dream-rn-listen dream-rn-router {:port 9000}))
+(dream-rn-test "listen returns" dream-rn-result :listening)
+(dream-rn-test "listen op kind" (get dream-rn-captured :op) "http/listen")
+(dream-rn-test "listen port" (get dream-rn-captured :port) 9000)
+(dream-rn-test
+  "default port"
+  (get
+    (begin
+      (dream-run-with dream-rn-listen dream-rn-router {})
+      dream-rn-captured)
+    :port)
+  8080)
+;; the captured app is runnable
+(dream-rn-test
+  "captured app serves"
+  (get ((get dream-rn-captured :app) {:method "GET" :target "/"}) :body)
+  "home")
+
+(define dream-rn-tests-run! (fn () {:total (+ dream-rn-pass dream-rn-fail) :passed dream-rn-pass :failed dream-rn-fail :fails dream-rn-fails}))

lib/dream/tests/session.sx

@@ -0,0 +1,197 @@
+;; lib/dream/tests/session.sx — cookies, store, session round-trip, signed cookies.
+
+(define dream-ss-pass 0)
+(define dream-ss-fail 0)
+(define dream-ss-fails (list))
+
+(define
+  dream-ss-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-ss-pass (+ dream-ss-pass 1))
+      (begin
+        (set! dream-ss-fail (+ dream-ss-fail 1))
+        (append! dream-ss-fails {:name name :actual actual :expected expected})))))
+
+;; ── cookie parsing ─────────────────────────────────────────────────
+(define dream-ss-creq (dream-request "GET" "/" {:Cookie "a=1; b=2; dream.session=s9"} ""))
+(dream-ss-test "parse cookie a" (dream-cookie dream-ss-creq "a") "1")
+(dream-ss-test "parse cookie b" (dream-cookie dream-ss-creq "b") "2")
+(dream-ss-test
+  "parse session cookie"
+  (dream-cookie dream-ss-creq "dream.session")
+  "s9")
+(dream-ss-test "missing cookie nil" (dream-cookie dream-ss-creq "z") nil)
+(dream-ss-test
+  "no cookie header"
+  (dream-cookie (dream-request "GET" "/" {} "") "a")
+  nil)
+
+;; ── cookie building ────────────────────────────────────────────────
+(dream-ss-test
+  "build basic cookie"
+  (dr/build-cookie "k" "v" {})
+  "k=v; Path=/")
+(dream-ss-test
+  "build httponly samesite"
+  (dr/build-cookie "sid" "x" {:http-only true :same-site "Lax"})
+  "sid=x; Path=/; HttpOnly; SameSite=Lax")
+(dream-ss-test
+  "build max-age"
+  (dr/build-cookie "k" "v" {:max-age 0})
+  "k=v; Path=/; Max-Age=0")
+(dream-ss-test
+  "set-cookie appends"
+  (len
+    (dream-resp-cookies
+      (dream-set-cookie (dream-html "x") "k" "v" {})))
+  1)
+(dream-ss-test
+  "set-cookie two"
+  (len
+    (dream-resp-cookies
+      (dream-set-cookie
+        (dream-set-cookie (dream-html "x") "a" "1" {})
+        "b"
+        "2"
+        {})))
+  2)
+(dream-ss-test
+  "drop cookie max-age 0"
+  (contains?
+    (first (dream-resp-cookies (dream-drop-cookie (dream-html "x") "k")))
+    "Max-Age=0")
+  true)
+
+;; ── signed cookie values ───────────────────────────────────────────
+(dream-ss-test
+  "sign/unsign roundtrip"
+  (dream-cookie-unsign "k" (dream-cookie-sign "k" "s5"))
+  "s5")
+(dream-ss-test
+  "unsign wrong secret"
+  (dream-cookie-unsign "k2" (dream-cookie-sign "k" "s5"))
+  nil)
+(dream-ss-test "unsign tampered" (dream-cookie-unsign "k" "s5.999") nil)
+(dream-ss-test "unsign no dot" (dream-cookie-unsign "k" "s5") nil)
+(dream-ss-test "unsign nil" (dream-cookie-unsign "k" nil) nil)
+
+;; ── in-memory store ────────────────────────────────────────────────
+(define dream-ss-store (dream-memory-sessions))
+(define dream-ss-sid (dream-ss-store {:op "session/create"}))
+(dream-ss-test "create returns id" dream-ss-sid "s1")
+(dream-ss-test "new session exists" (dream-ss-store {:op "session/exists" :sid "s1"}) true)
+(dream-ss-test "absent session not exists" (dream-ss-store {:op "session/exists" :sid "s99"}) false)
+(dream-ss-test "get missing key nil" (dream-ss-store {:key "k" :op "session/get" :sid "s1"}) nil)
+(dream-ss-store {:val "ada" :key "user" :op "session/set" :sid "s1"})
+(dream-ss-test "set then get" (dream-ss-store {:key "user" :op "session/get" :sid "s1"}) "ada")
+(dream-ss-store {:val "admin" :key "role" :op "session/set" :sid "s1"})
+(dream-ss-test "load all fields" (dream-ss-store {:op "session/load" :sid "s1"}) {:role "admin" :user "ada"})
+(dream-ss-test "second create distinct" (dream-ss-store {:op "session/create"}) "s2")
+(dream-ss-store {:op "session/clear" :sid "s1"})
+(dream-ss-test "clear removes" (dream-ss-store {:op "session/exists" :sid "s1"}) false)
+
+;; ── middleware round-trip ──────────────────────────────────────────
+(define dream-ss-backend (dream-memory-sessions))
+(define
+  dream-ss-counter-h
+  (fn
+    (req)
+    (let
+      ((n (or (dream-session-field req "count") 0)))
+      (begin
+        (dream-set-session-field req "count" (+ n 1))
+        (dream-text (str "count=" (+ n 1)))))))
+(define dream-ss-app ((dream-sessions dream-ss-backend) dream-ss-counter-h))
+
+(define dream-ss-r1 (dream-ss-app (dream-request "GET" "/" {} "")))
+(dream-ss-test "first body count=1" (dream-resp-body dream-ss-r1) "count=1")
+(dream-ss-test
+  "first sets one cookie"
+  (len (dream-resp-cookies dream-ss-r1))
+  1)
+(dream-ss-test
+  "session cookie name+id"
+  (contains? (first (dream-resp-cookies dream-ss-r1)) "dream.session=s1")
+  true)
+(dream-ss-test
+  "session cookie httponly"
+  (contains? (first (dream-resp-cookies dream-ss-r1)) "HttpOnly")
+  true)
+
+(define dream-ss-r2 (dream-ss-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
+(dream-ss-test "second body count=2" (dream-resp-body dream-ss-r2) "count=2")
+(dream-ss-test
+  "second sets no cookie"
+  (len (dream-resp-cookies dream-ss-r2))
+  0)
+
+(define dream-ss-r3 (dream-ss-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
+(dream-ss-test "third body count=3" (dream-resp-body dream-ss-r3) "count=3")
+
+(define dream-ss-r4 (dream-ss-app (dream-request "GET" "/" {:Cookie "dream.session=bogus"} "")))
+(dream-ss-test
+  "bogus id starts fresh"
+  (dream-resp-body dream-ss-r4)
+  "count=1")
+(dream-ss-test
+  "bogus id gets new cookie"
+  (len (dream-resp-cookies dream-ss-r4))
+  1)
+
+;; ── session-all + invalidate via middleware ────────────────────────
+(dream-ss-test
+  "session-all shows count"
+  (dream-session-all
+    (assoc (dream-request "GET" "/" {} "") :dream-session {:io dream-ss-backend :sid "s1"}))
+  {:count 3})
+
+(define
+  dream-ss-invalidate-h
+  (fn (req) (begin (dream-invalidate-session req) (dream-text "bye"))))
+(define
+  dream-ss-app3
+  ((dream-sessions dream-ss-backend) dream-ss-invalidate-h))
+(dream-ss-app3 (dream-request "GET" "/" {:Cookie "dream.session=s1"} ""))
+(dream-ss-test "invalidate clears store" (dream-ss-backend {:op "session/exists" :sid "s1"}) false)
+
+;; ── signed session middleware ──────────────────────────────────────
+(define dream-ss-sbackend (dream-memory-sessions))
+(define
+  dream-ss-sapp
+  ((dream-sessions-signed dream-ss-sbackend "topsecret")
+    (fn (req) (dream-text (dream-session-id req)))))
+
+(define dream-ss-sr1 (dream-ss-sapp (dream-request "GET" "/" {} "")))
+(dream-ss-test "signed first sid" (dream-resp-body dream-ss-sr1) "s1")
+(dream-ss-test
+  "signed cookie is signed"
+  (contains? (first (dream-resp-cookies dream-ss-sr1)) "dream.session=s1.")
+  true)
+
+;; forged plaintext sid (no signature) is rejected -> a fresh session is made
+(dream-ss-test
+  "forged plaintext rejected -> new session"
+  (dream-resp-body (dream-ss-sapp (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
+  "s2")
+
+;; a validly-signed cookie reuses the session
+(define dream-ss-signed-val (dream-cookie-sign "topsecret" "s1"))
+(define dream-ss-sr3 (dream-ss-sapp (dream-request "GET" "/" {:Cookie (str "dream.session=" dream-ss-signed-val)} "")))
+(dream-ss-test "valid signed reuses s1" (dream-resp-body dream-ss-sr3) "s1")
+(dream-ss-test
+  "valid signed sets no new cookie"
+  (len (dream-resp-cookies dream-ss-sr3))
+  0)
+
+;; a cookie signed with the wrong secret is rejected
+(dream-ss-test
+  "wrong-secret signed rejected"
+  (=
+    (dream-resp-body (dream-ss-sapp (dream-request "GET" "/" {:Cookie (str "dream.session=" (dream-cookie-sign "other" "s1"))} "")))
+    "s1")
+  false)
+
+(define dream-ss-tests-run! (fn () {:total (+ dream-ss-pass dream-ss-fail) :passed dream-ss-pass :failed dream-ss-fail :fails dream-ss-fails}))

lib/dream/tests/static.sx

@@ -0,0 +1,125 @@
+;; lib/dream/tests/static.sx — content types, etags, 304, ranges, traversal.
+
+(define dream-st-pass 0)
+(define dream-st-fail 0)
+(define dream-st-fails (list))
+
+(define
+  dream-st-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-st-pass (+ dream-st-pass 1))
+      (begin
+        (set! dream-st-fail (+ dream-st-fail 1))
+        (append! dream-st-fails {:name name :actual actual :expected expected})))))
+
+;; ── content type + ext ─────────────────────────────────────────────
+(dream-st-test "ext css" (dr/ext-of "a/b/style.css") "css")
+(dream-st-test "ext multi-dot" (dr/ext-of "a.min.js") "js")
+(dream-st-test "ext none" (dr/ext-of "README") "")
+(dream-st-test
+  "ctype css"
+  (dream-content-type-for "x.css")
+  "text/css; charset=utf-8")
+(dream-st-test
+  "ctype html"
+  (dream-content-type-for "x.html")
+  "text/html; charset=utf-8")
+(dream-st-test "ctype png" (dream-content-type-for "x.png") "image/png")
+(dream-st-test
+  "ctype unknown"
+  (dream-content-type-for "x.bin")
+  "application/octet-stream")
+
+;; ── etag ───────────────────────────────────────────────────────────
+(dream-st-test
+  "etag deterministic"
+  (= (dr/etag-of "abc") (dr/etag-of "abc"))
+  true)
+(dream-st-test
+  "etag content-sensitive"
+  (= (dr/etag-of "abc") (dr/etag-of "abd"))
+  false)
+(dream-st-test
+  "etag length-sensitive"
+  (= (dr/etag-of "ab") (dr/etag-of "abc"))
+  false)
+
+;; ── serving via router mount ───────────────────────────────────────
+(define dream-st-files {:/srv/app.css "body{color:red}" :/srv/index.html "<h1>Hi</h1>"})
+(define dream-st-fs (dream-memory-fs dream-st-files))
+(define
+  dream-st-app
+  (dream-router
+    (list (dream-get "/static/**" (dream-static-with "/srv" dream-st-fs)))))
+(define
+  dream-st-get
+  (fn
+    (target headers)
+    (dream-st-app (dream-request "GET" target headers ""))))
+
+(define dream-st-css (dream-st-get "/static/app.css" {}))
+(dream-st-test "serve status 200" (dream-status dream-st-css) 200)
+(dream-st-test "serve body" (dream-resp-body dream-st-css) "body{color:red}")
+(dream-st-test
+  "serve content-type"
+  (dream-resp-header dream-st-css "content-type")
+  "text/css; charset=utf-8")
+(dream-st-test
+  "serve accept-ranges"
+  (dream-resp-header dream-st-css "accept-ranges")
+  "bytes")
+(dream-st-test
+  "serve has etag"
+  (not (nil? (dream-resp-header dream-st-css "etag")))
+  true)
+(dream-st-test
+  "missing file 404"
+  (dream-status (dream-st-get "/static/nope.txt" {}))
+  404)
+(dream-st-test
+  "traversal blocked 403"
+  (dream-status (dream-st-get "/static/../secret" {}))
+  403)
+
+;; ── conditional: If-None-Match -> 304 ──────────────────────────────
+(define dream-st-etag (dream-resp-header dream-st-css "etag"))
+(define dream-st-304 (dream-st-get "/static/app.css" {:If-None-Match dream-st-etag}))
+(dream-st-test "matching etag 304" (dream-status dream-st-304) 304)
+(dream-st-test "304 empty body" (dream-resp-body dream-st-304) "")
+(dream-st-test
+  "stale etag 200"
+  (dream-status (dream-st-get "/static/app.css" {:If-None-Match "\"stale\""}))
+  200)
+(dream-st-test
+  "star etag 304"
+  (dream-status (dream-st-get "/static/app.css" {:If-None-Match "*"}))
+  304)
+
+;; ── range requests ─────────────────────────────────────────────────
+(define dream-st-range (dream-st-get "/static/app.css" {:Range "bytes=0-3"}))
+(dream-st-test "range status 206" (dream-status dream-st-range) 206)
+(dream-st-test "range body slice" (dream-resp-body dream-st-range) "body")
+(dream-st-test
+  "range content-range"
+  (dream-resp-header dream-st-range "content-range")
+  "bytes 0-3/15")
+(define dream-st-open (dream-st-get "/static/app.css" {:Range "bytes=5-"}))
+(dream-st-test "open range body" (dream-resp-body dream-st-open) "color:red}")
+(dream-st-test
+  "open range header"
+  (dream-resp-header dream-st-open "content-range")
+  "bytes 5-14/15")
+(define dream-st-bad (dream-st-get "/static/app.css" {:Range "bytes=20-30"}))
+(dream-st-test
+  "unsatisfiable range 416"
+  (dream-status dream-st-bad)
+  416)
+(dream-st-test
+  "416 content-range"
+  (dream-resp-header dream-st-bad "content-range")
+  "bytes */15")
+
+(define dream-st-tests-run! (fn () {:total (+ dream-st-pass dream-st-fail) :passed dream-st-pass :failed dream-st-fail :fails dream-st-fails}))

lib/dream/tests/types.sx

@@ -0,0 +1,199 @@
+;; lib/dream/tests/types.sx — request/response/route records + convenience.
+
+(define dream-ty-pass 0)
+(define dream-ty-fail 0)
+(define dream-ty-fails (list))
+
+(define
+  dream-ty-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-ty-pass (+ dream-ty-pass 1))
+      (begin
+        (set! dream-ty-fail (+ dream-ty-fail 1))
+        (append! dream-ty-fails {:name name :actual actual :expected expected})))))
+
+;; ── request construction + accessors ───────────────────────────────
+(define
+  dream-ty-req
+  (dream-request "get" "/users/42?tab=info&x=1" {:X-Token "abc" :Content-Type "text/html"} "hello"))
+
+(dream-ty-test "method uppercased" (dream-method dream-ty-req) "GET")
+(dream-ty-test "path strips query" (dream-path dream-ty-req) "/users/42")
+(dream-ty-test
+  "target keeps query"
+  (dream-target dream-ty-req)
+  "/users/42?tab=info&x=1")
+(dream-ty-test "body" (dream-body dream-ty-req) "hello")
+(dream-ty-test
+  "header case-insensitive"
+  (dream-header dream-ty-req "content-type")
+  "text/html")
+(dream-ty-test
+  "header mixed case"
+  (dream-header dream-ty-req "X-Token")
+  "abc")
+(dream-ty-test
+  "missing header is nil"
+  (dream-header dream-ty-req "absent")
+  nil)
+(dream-ty-test
+  "query param tab"
+  (dream-query-param dream-ty-req "tab")
+  "info")
+(dream-ty-test "query param x" (dream-query-param dream-ty-req "x") "1")
+(dream-ty-test "params empty by default" (dream-param dream-ty-req "id") nil)
+(dream-ty-test "is a request" (dream-request? dream-ty-req) true)
+(dream-ty-test "string is not a request" (dream-request? "x") false)
+
+;; ── query edge cases ───────────────────────────────────────────────
+(dream-ty-test
+  "no query is empty"
+  (dream-query-param (dream-request "GET" "/plain" {} "") "k")
+  nil)
+(dream-ty-test
+  "valueless query param"
+  (dream-query-param (dream-request "GET" "/p?flag" {} "") "flag")
+  "")
+
+;; ── path params ────────────────────────────────────────────────────
+(define dream-ty-req2 (dream-with-param dream-ty-req "id" "42"))
+(dream-ty-test "with-param sets" (dream-param dream-ty-req2 "id") "42")
+(dream-ty-test "with-param immutable" (dream-param dream-ty-req "id") nil)
+(define dream-ty-req3 (dream-with-params dream-ty-req {:a "1" :b "2"}))
+(dream-ty-test "with-params a" (dream-param dream-ty-req3 "a") "1")
+(dream-ty-test "with-params b" (dream-param dream-ty-req3 "b") "2")
+
+;; ── request convenience ────────────────────────────────────────────
+(dream-ty-test "queries dict" (dream-queries dream-ty-req) {:x "1" :tab "info"})
+(dream-ty-test
+  "query-or present"
+  (dream-query-param-or dream-ty-req "tab" "def")
+  "info")
+(dream-ty-test
+  "query-or default"
+  (dream-query-param-or dream-ty-req "missing" "def")
+  "def")
+(dream-ty-test "has-query yes" (dream-has-query? dream-ty-req "tab") true)
+(dream-ty-test "has-query no" (dream-has-query? dream-ty-req "nope") false)
+(dream-ty-test
+  "header-or present"
+  (dream-header-or dream-ty-req "x-token" "d")
+  "abc")
+(dream-ty-test
+  "header-or default"
+  (dream-header-or dream-ty-req "x-absent" "d")
+  "d")
+(dream-ty-test
+  "has-header yes"
+  (dream-has-header? dream-ty-req "Content-Type")
+  true)
+(dream-ty-test
+  "has-header no"
+  (dream-has-header? dream-ty-req "x-absent")
+  false)
+(dream-ty-test "param-or default" (dream-param-or dream-ty-req "id" "0") "0")
+(dream-ty-test
+  "param-or present"
+  (dream-param-or dream-ty-req2 "id" "0")
+  "42")
+(dream-ty-test
+  "content-type-of"
+  (dream-content-type-of dream-ty-req)
+  "text/html")
+(dream-ty-test "method-is yes" (dream-method-is? dream-ty-req "get") true)
+(dream-ty-test "method-is no" (dream-method-is? dream-ty-req "post") false)
+(define dream-ty-jreq (dream-request "GET" "/" {:Accept "application/json, text/html"} ""))
+(dream-ty-test
+  "accepts json"
+  (dream-accepts? dream-ty-jreq "application/json")
+  true)
+(dream-ty-test
+  "accepts missing"
+  (dream-accepts? dream-ty-req "application/json")
+  false)
+(dream-ty-test "wants-json yes" (dream-wants-json? dream-ty-jreq) true)
+(dream-ty-test "wants-json no" (dream-wants-json? dream-ty-req) false)
+
+;; ── response construction ──────────────────────────────────────────
+(dream-ty-test "html status" (dream-status (dream-html "<p>")) 200)
+(dream-ty-test "html body" (dream-resp-body (dream-html "<p>")) "<p>")
+(dream-ty-test
+  "html content-type"
+  (dream-resp-header (dream-html "<p>") "content-type")
+  "text/html; charset=utf-8")
+(dream-ty-test
+  "text content-type"
+  (dream-resp-header (dream-text "hi") "content-type")
+  "text/plain; charset=utf-8")
+(dream-ty-test
+  "json content-type"
+  (dream-resp-header (dream-json "{}") "content-type")
+  "application/json")
+(dream-ty-test
+  "html-status code"
+  (dream-status (dream-html-status 201 "ok"))
+  201)
+(dream-ty-test
+  "not-found status"
+  (dream-status (dream-not-found))
+  404)
+(dream-ty-test
+  "empty status"
+  (dream-status (dream-empty 204))
+  204)
+(dream-ty-test "empty body" (dream-resp-body (dream-empty 204)) "")
+(dream-ty-test
+  "redirect status"
+  (dream-status (dream-redirect "/home"))
+  303)
+(dream-ty-test
+  "redirect location"
+  (dream-resp-header (dream-redirect "/home") "location")
+  "/home")
+(dream-ty-test
+  "redirect-status code"
+  (dream-status (dream-redirect-status 301 "/x"))
+  301)
+(dream-ty-test "is a response" (dream-response? (dream-html "x")) true)
+
+;; ── response mutation ──────────────────────────────────────────────
+(define dream-ty-resp (dream-add-header (dream-html "x") "X-Custom" "yes"))
+(dream-ty-test
+  "add-header"
+  (dream-resp-header dream-ty-resp "x-custom")
+  "yes")
+(dream-ty-test "add-header keeps body" (dream-resp-body dream-ty-resp) "x")
+(dream-ty-test
+  "set-status"
+  (dream-status (dream-set-status (dream-html "x") 500))
+  500)
+
+;; ── coercion ───────────────────────────────────────────────────────
+(dream-ty-test
+  "coerce string"
+  (dream-status (dream-coerce-response "hi"))
+  200)
+(dream-ty-test
+  "coerce string body"
+  (dream-resp-body (dream-coerce-response "hi"))
+  "hi")
+(dream-ty-test
+  "coerce response passthrough"
+  (dream-status (dream-coerce-response (dream-empty 204)))
+  204)
+
+;; ── route ──────────────────────────────────────────────────────────
+(define dream-ty-h (fn (req) (dream-text "ok")))
+(define dream-ty-route (dream-route "post" "/submit" dream-ty-h))
+(dream-ty-test "route method" (dream-route-method dream-ty-route) "POST")
+(dream-ty-test "route path" (dream-route-path dream-ty-route) "/submit")
+(dream-ty-test "route is route" (dream-route? dream-ty-route) true)
+(dream-ty-test
+  "route handler invokes"
+  (dream-resp-body ((dream-route-handler dream-ty-route) dream-ty-req))
+  "ok")
+
+(define dream-ty-tests-run! (fn () {:total (+ dream-ty-pass dream-ty-fail) :passed dream-ty-pass :failed dream-ty-fail :fails dream-ty-fails}))

lib/dream/tests/websocket.sx

@@ -0,0 +1,94 @@
+;; lib/dream/tests/websocket.sx — upgrade, send/receive/close, broadcast.
+
+(define dream-ws-pass 0)
+(define dream-ws-fail 0)
+(define dream-ws-fails (list))
+
+(define
+  dream-ws-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! dream-ws-pass (+ dream-ws-pass 1))
+      (begin
+        (set! dream-ws-fail (+ dream-ws-fail 1))
+        (append! dream-ws-fails {:name name :actual actual :expected expected})))))
+
+;; ── upgrade response ───────────────────────────────────────────────
+(define dream-ws-echo (fn (ws) (dream-text "unused")))
+(define
+  dream-ws-up
+  ((dream-websocket dream-ws-echo) (dream-request "GET" "/ws" {} "")))
+(dream-ws-test "upgrade status 101" (dream-status dream-ws-up) 101)
+(dream-ws-test "is a websocket response" (dream-websocket? dream-ws-up) true)
+(dream-ws-test
+  "plain response is not ws"
+  (dream-websocket? (dream-html "x"))
+  false)
+(dream-ws-test
+  "upgrade header"
+  (dream-resp-header dream-ws-up "upgrade")
+  "websocket")
+
+;; ── basic send / receive / close on a mock ─────────────────────────
+(define dream-ws-w1 (dream-mock-ws (list "hi" "there")))
+(dream-ws-test "open initially" (dream-ws-open? dream-ws-w1) true)
+(dream-ws-test "receive first" (dream-receive dream-ws-w1) "hi")
+(dream-ws-test "receive second" (dream-receive dream-ws-w1) "there")
+(dream-ws-test "receive empty -> nil" (dream-receive dream-ws-w1) nil)
+(dream-send dream-ws-w1 "out1")
+(dream-send dream-ws-w1 "out2")
+(dream-ws-test
+  "sent recorded"
+  (dream-ws-sent dream-ws-w1)
+  (list "out1" "out2"))
+(dream-close dream-ws-w1)
+(dream-ws-test "closed flag" (dream-ws-closed? dream-ws-w1) true)
+(dream-ws-test "open? false after close" (dream-ws-open? dream-ws-w1) false)
+
+;; ── echo handler driven over the upgrade response ──────────────────
+(define
+  dream-ws-echo-h
+  (fn
+    (ws)
+    (let
+      ((m (dream-receive ws)))
+      (if
+        (nil? m)
+        (dream-close ws)
+        (begin (dream-send ws (str "echo:" m)) (dream-ws-echo-h ws))))))
+(define
+  dream-ws-echo-up
+  ((dream-websocket dream-ws-echo-h)
+    (dream-request "GET" "/ws" {} "")))
+(define dream-ws-echo-conn (dream-mock-ws (list "a" "b" "c")))
+(dream-ws-run dream-ws-echo-up dream-ws-echo-conn)
+(dream-ws-test
+  "echo all messages"
+  (dream-ws-sent dream-ws-echo-conn)
+  (list "echo:a" "echo:b" "echo:c"))
+(dream-ws-test
+  "echo closes at end"
+  (dream-ws-closed? dream-ws-echo-conn)
+  true)
+
+;; ── broadcast to a room ────────────────────────────────────────────
+(define dream-ws-c1 (dream-mock-ws (list)))
+(define dream-ws-c2 (dream-mock-ws (list)))
+(define dream-ws-c3 (dream-mock-ws (list)))
+(dream-ws-broadcast (list dream-ws-c1 dream-ws-c2 dream-ws-c3) "hello room")
+(dream-ws-test
+  "broadcast c1"
+  (dream-ws-sent dream-ws-c1)
+  (list "hello room"))
+(dream-ws-test
+  "broadcast c2"
+  (dream-ws-sent dream-ws-c2)
+  (list "hello room"))
+(dream-ws-test
+  "broadcast c3"
+  (dream-ws-sent dream-ws-c3)
+  (list "hello room"))
+
+(define dream-ws-tests-run! (fn () {:total (+ dream-ws-pass dream-ws-fail) :passed dream-ws-pass :failed dream-ws-fail :fails dream-ws-fails}))

lib/dream/types.sx

@@ -0,0 +1,175 @@
+;; lib/dream/types.sx — Dream-on-SX core types.
+;; The five types: request, response, route. handler = request->response and
+;; middleware = handler->handler are plain SX functions (no records needed).
+;; request/response/route are dicts. Headers are dicts with lowercased string
+;; keys; keywords are strings in SX, so :content-type == "content-type".
+
+;; ── internal helpers ───────────────────────────────────────────────
+(define
+  dr/normalize-headers
+  (fn
+    (h)
+    (reduce
+      (fn (acc k) (assoc acc (lower k) (get h k)))
+      {}
+      (keys h))))
+
+(define
+  dr/path-of
+  (fn
+    (target)
+    (let
+      ((i (index-of target "?")))
+      (if (< i 0) target (substr target 0 i)))))
+
+(define
+  dr/query-of
+  (fn
+    (target)
+    (let
+      ((i (index-of target "?")))
+      (if (< i 0) "" (substr target (+ i 1))))))
+
+(define
+  dr/parse-pair
+  (fn
+    (acc pair)
+    (if
+      (= pair "")
+      acc
+      (let
+        ((j (index-of pair "=")))
+        (if
+          (< j 0)
+          (assoc acc pair "")
+          (assoc
+            acc
+            (substr pair 0 j)
+            (substr pair (+ j 1))))))))
+
+(define
+  dr/parse-query
+  (fn
+    (target)
+    (let
+      ((q (dr/query-of target)))
+      (if
+        (= q "")
+        {}
+        (reduce dr/parse-pair {} (split q "&"))))))
+
+;; ── request ────────────────────────────────────────────────────────
+(define dream-request (fn (method target headers body) {:path (dr/path-of target) :params {} :query (dr/parse-query target) :body body :headers (dr/normalize-headers headers) :method (upper method) :target target}))
+
+(define
+  dream-request?
+  (fn (x) (and (dict? x) (has-key? x :method) (has-key? x :path))))
+(define dream-method (fn (req) (get req :method)))
+(define dream-target (fn (req) (get req :target)))
+(define dream-path (fn (req) (get req :path)))
+(define dream-body (fn (req) (get req :body)))
+(define
+  dream-header
+  (fn (req name) (get (get req :headers) (lower name))))
+(define dream-query-param (fn (req name) (get (get req :query) name)))
+(define dream-param (fn (req name) (get (get req :params) name)))
+(define dream-params (fn (req) (get req :params)))
+
+;; router fills path params during dispatch
+(define
+  dream-with-param
+  (fn
+    (req name val)
+    (assoc req :params (assoc (get req :params) name val))))
+(define
+  dream-with-params
+  (fn
+    (req more)
+    (assoc
+      req
+      :params (reduce
+        (fn (acc k) (assoc acc k (get more k)))
+        (get req :params)
+        (keys more)))))
+(define dream-set-body (fn (req body) (assoc req :body body)))
+
+;; ── request convenience ────────────────────────────────────────────
+(define dream-queries (fn (req) (get req :query)))
+(define
+  dream-query-param-or
+  (fn (req name default) (or (dream-query-param req name) default)))
+(define dream-has-query? (fn (req name) (has-key? (get req :query) name)))
+(define
+  dream-header-or
+  (fn (req name default) (or (dream-header req name) default)))
+(define
+  dream-has-header?
+  (fn (req name) (has-key? (get req :headers) (lower name))))
+(define
+  dream-param-or
+  (fn (req name default) (or (dream-param req name) default)))
+(define dream-has-param? (fn (req name) (has-key? (get req :params) name)))
+(define dream-content-type-of (fn (req) (dream-header req "content-type")))
+(define dream-method-is? (fn (req m) (= (dream-method req) (upper m))))
+(define
+  dream-accepts?
+  (fn
+    (req mime)
+    (let
+      ((a (dream-header req "accept")))
+      (if a (contains? a mime) false))))
+(define
+  dream-wants-json?
+  (fn (req) (dream-accepts? req "application/json")))
+
+;; ── response ───────────────────────────────────────────────────────
+(define dream-response (fn (status headers body) {:body body :headers (dr/normalize-headers headers) :status status}))
+
+(define
+  dream-response?
+  (fn (x) (and (dict? x) (has-key? x :status) (has-key? x :body))))
+(define dream-status (fn (resp) (get resp :status)))
+(define
+  dream-resp-header
+  (fn (resp name) (get (get resp :headers) (lower name))))
+(define dream-resp-body (fn (resp) (get resp :body)))
+(define dream-headers (fn (resp) (get resp :headers)))
+
+(define
+  dream-add-header
+  (fn
+    (resp name val)
+    (assoc resp :headers (assoc (get resp :headers) (lower name) val))))
+(define dream-set-status (fn (resp status) (assoc resp :status status)))
+
+;; smart constructors
+(define dream-html (fn (body) (dream-response 200 {:content-type "text/html; charset=utf-8"} body)))
+(define
+  dream-html-status
+  (fn (status body) (dream-response status {:content-type "text/html; charset=utf-8"} body)))
+(define dream-text (fn (body) (dream-response 200 {:content-type "text/plain; charset=utf-8"} body)))
+(define dream-json (fn (body) (dream-response 200 {:content-type "application/json"} body)))
+(define dream-empty (fn (status) (dream-response status {} "")))
+(define
+  dream-not-found
+  (fn () (dream-response 404 {:content-type "text/plain; charset=utf-8"} "Not Found")))
+(define
+  dream-redirect
+  (fn (location) (dream-response 303 {:location location} "")))
+(define
+  dream-redirect-status
+  (fn (status location) (dream-response status {:location location} "")))
+
+;; coerce a handler result: strings become 200 text/html responses
+(define
+  dream-coerce-response
+  (fn (x) (if (dream-response? x) x (dream-html x))))
+
+;; ── route ──────────────────────────────────────────────────────────
+(define dream-route (fn (method path handler) {:path path :handler handler :method (upper method)}))
+(define
+  dream-route?
+  (fn (x) (and (dict? x) (has-key? x :handler) (has-key? x :path))))
+(define dream-route-method (fn (r) (get r :method)))
+(define dream-route-path (fn (r) (get r :path)))
+(define dream-route-handler (fn (r) (get r :handler)))

lib/dream/websocket.sx

@@ -0,0 +1,42 @@
+;; lib/dream/websocket.sx — Dream-on-SX WebSockets.
+;; dream-websocket wraps a (fn (ws) ...) handler into an ordinary handler that
+;; returns a 101 upgrade response carrying the ws handler. The host detects the
+;; upgrade, builds a ws backed by host IO, and runs the handler. The ws carries an
+;; injectable io fn — a mock in-memory ws for tests, (perform op) in production.
+;; Depends on types.sx.
+
+;; ── upgrade response ───────────────────────────────────────────────
+(define dream-websocket (fn (handler) (fn (req) {:websocket handler :body "" :headers {:connection "Upgrade" :upgrade "websocket"} :status 101})))
+
+(define
+  dream-websocket?
+  (fn (resp) (and (dict? resp) (has-key? resp :websocket))))
+(define dream-ws-handler (fn (resp) (get resp :websocket)))
+
+;; ── ws operations (over an injectable io) ──────────────────────────
+(define dream-send (fn (ws msg) ((get ws :io) {:op "ws/send" :msg msg})))
+(define dream-receive (fn (ws) ((get ws :io) {:op "ws/receive"})))
+(define dream-close (fn (ws) ((get ws :io) {:op "ws/close"})))
+(define dream-ws-open? (fn (ws) ((get ws :io) {:op "ws/open?"})))
+(define
+  dream-ws-broadcast
+  (fn (wss msg) (for-each (fn (ws) (dream-send ws msg)) wss)))
+
+;; production io: every op suspends to the host
+(define dream-ws-perform-io (fn (op) (perform op)))
+(define dream-ws-from-io (fn (io) {:io io}))
+
+;; ── in-memory mock ws (tests + demos) ──────────────────────────────
+;; incoming is a list of messages dream-receive will yield in order.
+(define
+  dream-mock-ws
+  (fn
+    (incoming)
+    (let ((inbox incoming) (outbox (list)) (closed false)) {:closed? (fn () closed) :outbox (fn () outbox) :io (fn (op) (cond ((= (get op :op) "ws/send") (begin (set! outbox (concat outbox (list (get op :msg)))) true)) ((= (get op :op) "ws/receive") (if (empty? inbox) nil (let ((m (first inbox))) (begin (set! inbox (rest inbox)) m)))) ((= (get op :op) "ws/close") (begin (set! closed true) true)) ((= (get op :op) "ws/open?") (not closed)) (else nil)))})))
+
+;; test/demo introspection
+(define dream-ws-sent (fn (ws) ((get ws :outbox))))
+(define dream-ws-closed? (fn (ws) ((get ws :closed?))))
+
+;; drive a ws handler (from an upgrade response) against a ws
+(define dream-ws-run (fn (resp ws) ((dream-ws-handler resp) ws)))

lib/host/blog.sx

@@ -0,0 +1,254 @@
+;; lib/host/blog.sx — Blog domain on the host, on the EDITOR's content model.
+;; The SX post editor (blog/sx/editor.sx) emits `sx_content`: SX element markup
+;; (e.g. "(article (h1 \"T\") (p \"body\" (strong \"x\")))"), NOT content-on-sx
+;; CtDoc blocks. So a post here is a record {slug,title,sx_content,status} stored
+;; in the durable persist KV, and a post page is `render-to-html (parse sx_content)`
+;; — server-side, static, no client runtime needed to view a published post.
+;;
+;;   GET    /              HTML index of posts (public)
+;;   GET    /<slug>/       rendered post (public) -> HTML / 404
+;;   GET    /posts         JSON list (public)     -> [{slug,title,status}]
+;;   GET    /new           HTML create form (public chrome)
+;;   POST   /new           form-urlencoded ingest from the editor (guarded)
+;;   POST   /posts         JSON create (guarded)
+;;   PUT    /posts/<slug>  JSON update (guarded)
+;;   DELETE /posts/<slug>  delete (guarded)
+;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog").
+;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/*
+;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx.
+
+;; ── store (durable persist KV, injectable) ──────────────────────────
+(define host/blog-store (persist/open))
+(define host/blog-use-store! (fn (b) (set! host/blog-store b)))
+(define host/blog--key (fn (slug) (str "blog:" slug)))
+
+;; slug from a title: lowercase, words joined by '-'. (Punctuation kept simple.)
+(define host/blog-slugify
+  (fn (title)
+    (join "-" (filter (fn (w) (not (= w ""))) (split (lower title) " ")))))
+
+;; ── records ─────────────────────────────────────────────────────────
+(define host/blog-get
+  (fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug))))
+(define host/blog-exists?
+  (fn (slug) (persist/backend-kv-has? host/blog-store (host/blog--key slug))))
+(define host/blog-put!
+  (fn (slug title sx-content status)
+    (persist/backend-kv-put host/blog-store (host/blog--key slug)
+      {:slug slug :title title :sx-content sx-content :status status})))
+(define host/blog-delete!
+  (fn (slug) (persist/backend-kv-delete host/blog-store (host/blog--key slug))))
+(define host/blog-seed!
+  (fn (slug title sx-content status)
+    (when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status))))
+
+;; all blog slugs (kv keys are "blog:<slug>")
+(define host/blog-slugs
+  (fn ()
+    (reduce
+      (fn (acc k)
+        (if (starts-with? k "blog:") (append acc (list (substr k 5))) acc))
+      (list)
+      (persist/backend-kv-keys host/blog-store))))
+(define host/blog-list
+  (fn ()
+    (map
+      (fn (slug)
+        (let ((r (host/blog-get slug)))
+          {:slug slug :title (get r :title) :status (get r :status)}))
+      (host/blog-slugs))))
+
+;; ── render ──────────────────────────────────────────────────────────
+;; A post's sx_content is SX element markup -> HTML via render-page (which supplies
+;; the server env so components resolve + keyword attrs are kept).
+;;
+;; Rendered PER BLOCK and guarded: the editor wraps content in a (<> ...) fragment
+;; of blocks, some of which the host can't render (the legacy editor emits bare
+;; ~kg-md cards while the components are ~kg_cards/kg-md — drift we don't paper over
+;; with aliases). Rendering each block under its own guard means the real prose
+;; (p/h1/ul/...) shows and only the unsupported block degrades to a placeholder —
+;; and a bad block never crashes the handler (-> 502).
+(define host/blog--render-node
+  (fn (node)
+    (guard (e (true "<div class=\"blk-unsupported\"><em>(unsupported block)</em></div>"))
+      (render-page node))))
+(define host/blog-render
+  (fn (record)
+    (let ((sx (get record :sx-content)))
+      (if (and sx (not (= sx "")))
+        (let ((tree (guard (e (true nil)) (parse sx))))
+          (cond
+            ((nil? tree) "<p><em>(unparseable content)</em></p>")
+            ((and (= (type-of tree) "list") (> (len tree) 0)
+                  (= (str (first tree)) "<>"))
+              (join "" (map host/blog--render-node (rest tree))))
+            (else (host/blog--render-node tree))))
+        (str "<p>(empty post)</p>")))))
+;; ── page shell ──────────────────────────────────────────────────────
+;; A page is an SX element tree, rendered via render-page (5.1). The handler
+;; builds the tree (running any dynamic logic in the full evaluator, e.g. a posts
+;; loop) and render-page renders the static result — no embedded HTML strings,
+;; only the doctype prefix render-to-html doesn't emit. `body` is an SX node.
+(define host/blog--page
+  (fn (title body)
+    (str "<!doctype html>"
+      (render-page
+        (quasiquote
+          (html
+            (head (meta :charset "utf-8") (title (unquote title)))
+            (body (unquote body))))))))
+
+;; ── read handlers ───────────────────────────────────────────────────
+;; Post body is rendered per-block (a guarded HTML string) then injected raw.
+(define host/blog-post
+  (fn (req)
+    (let ((slug (dream-param req "slug")))
+      (let ((r (host/blog-get slug)))
+        (if r
+          (dream-html
+            (host/blog--page (get r :title)
+              (quasiquote (article (raw! (unquote (host/blog-render r)))))))
+          (dream-html-status 404
+            (host/blog--page "Not found"
+              (quasiquote
+                (div (h1 "404")
+                  (p (unquote (str "No published post: " slug))))))))))))
+
+(define host/blog-home
+  (fn (req)
+    (let ((posts (host/blog-list)))
+      (let ((items
+              (map
+                (fn (p)
+                  (quasiquote
+                    (li (a :href (unquote (str "/" (get p :slug) "/"))
+                          (unquote (get p :title))))))
+                posts)))
+        (let ((listing (if (> (len posts) 0)
+                         (list (quote ul) items)
+                         (quote (p "No posts yet.")))))
+          (dream-html
+            (host/blog--page "Blog"
+              (quasiquote
+                (div (h1 "Posts")
+                  (unquote listing)
+                  (p (a :href "/new" "+ New post")))))))))))
+
+(define host/blog-index (fn (req) (host/ok (host/blog-list))))
+
+;; ── create page (GET /new) — clean minimal form as an SX tree ───────
+;; No legacy JS editor, no external assets, no shims. The rich WYSIWYG is a
+;; future native SX-island editor (Phase 5.2+). Posts to /new.
+(define host/blog-new-form
+  (fn (req)
+    (dream-html
+      (host/blog--page "New post"
+        (quasiquote
+          (div
+            (h1 "New post")
+            (form :method "post" :action "/new"
+              (p (input :name "title" :placeholder "Title"
+                   :style "font-size:1.4em;width:100%"))
+              (p (textarea :name "sx_content" :rows "12"
+                   :style "width:100%;font-family:monospace"
+                   :placeholder "(p \"Your post as SX markup\")"))
+              (p (select :name "status"
+                   (option :value "draft" "Draft")
+                   (option :value "published" "Published"))
+                " "
+                (button :type "submit" "Publish")))
+            (p (a :href "/" "all posts"))))))))
+
+;; ── write handlers ──────────────────────────────────────────────────
+;; POST /new — form-urlencoded ingest (the editor's submit shape: title,
+;; sx_content, status, custom_excerpt, csrf_token). Slug derived from the title.
+;; Redirects to the new post on success.
+(define host/blog-form-submit
+  (fn (req)
+    (let ((title (dream-form-field req "title"))
+          (sx-content (dream-form-field req "sx_content"))
+          (status (or (dream-form-field req "status") "published")))
+      (if (and title (not (= title "")))
+        (let ((slug (host/blog-slugify title)))
+          (begin
+            (host/blog-put! slug title (or sx-content "") status)
+            (dream-redirect (str "/" slug "/"))))
+        (dream-html-status 400
+          (host/blog--page "Error" "<p>Title is required. <a href=\"/new\">back</a></p>"))))))
+
+;; POST /posts — JSON create {slug?,title,sx_content,status}. 409 if slug exists.
+(define host/blog-create
+  (fn (req)
+    (let ((p (dream-json-body req)))
+      (if (= (type-of p) "dict")
+        (let ((title (get p :title)))
+          (if (and title (not (= title "")))
+            (let ((slug (or (get p :slug) (host/blog-slugify title))))
+              (if (host/blog-exists? slug)
+                (host/error 409 "post already exists")
+                (begin
+                  (host/blog-put! slug title (or (get p :sx_content) "")
+                    (or (get p :status) "published"))
+                  (host/ok-status 201 {:slug slug :title title}))))
+            (host/error 400 "title required")))
+        (host/error 400 "invalid payload")))))
+
+;; PUT /posts/<slug> — JSON update {title?,sx_content?,status?}. 404 if absent.
+(define host/blog-update-handler
+  (fn (req)
+    (let ((slug (dream-param req "slug")) (p (dream-json-body req)))
+      (if (= (type-of p) "dict")
+        (let ((r (host/blog-get slug)))
+          (if r
+            (begin
+              (host/blog-put! slug
+                (or (get p :title) (get r :title))
+                (or (get p :sx_content) (get r :sx-content))
+                (or (get p :status) (get r :status)))
+              (host/ok {:slug slug :updated true}))
+            (host/error 404 "no such post")))
+        (host/error 400 "invalid payload")))))
+
+;; DELETE /posts/<slug>
+(define host/blog-delete-handler
+  (fn (req)
+    (let ((slug (dream-param req "slug")))
+      (if (host/blog-exists? slug)
+        (begin (host/blog-delete! slug) (host/ok {:slug slug :deleted true}))
+        (host/error 404 "no such post")))))
+
+;; ── routes ──────────────────────────────────────────────────────────
+;; Public reads + the create form. /, /posts, /new BEFORE /:slug (catch-all).
+;; MUST be mounted LAST in the app so domain routes (/feed, /health) win.
+(define host/blog-routes
+  (list
+    (dream-get "/" host/blog-home)
+    (dream-get "/posts" host/blog-index)
+    (dream-get "/new" host/blog-new-form)
+    (dream-get "/:slug" host/blog-post)))
+
+;; Guarded writes: form ingest + JSON create/update/delete behind auth+ACL.
+;; NB: helper is host/blog--protect, NOT `guard` (reserved special form).
+(define host/blog--protect
+  (fn (resolve h)
+    (host/pipeline
+      (list
+        host/wrap-errors
+        (host/require-auth resolve)
+        (host/require-permission "edit" (fn (req) "blog")))
+      h)))
+(define host/blog-write-routes
+  (fn (resolve)
+    (list
+      (dream-post "/new" (host/blog--protect resolve host/blog-form-submit))
+      (dream-post "/posts" (host/blog--protect resolve host/blog-create))
+      (dream-put "/posts/:slug" (host/blog--protect resolve host/blog-update-handler))
+      (dream-delete "/posts/:slug" (host/blog--protect resolve host/blog-delete-handler)))))
+
+;; EXPERIMENTAL: create-only, UNGUARDED — POST /new form ingest with error
+;; trapping but NO auth, for validating the editor->host publish loop on the
+;; experimental subdomain. Create-only by design (no PUT/DELETE), so the worst
+;; case is junk posts, not overwrite/delete. GATE before any real use.
+(define host/blog-open-create-routes
+  (list
+    (dream-post "/new" (host/pipeline (list host/wrap-errors) host/blog-form-submit))))

lib/host/conformance.sh

@@ -0,0 +1,163 @@
+#!/usr/bin/env bash
+# host-on-sx conformance runner — loads the kernel stdlib, the subsystem
+# libraries the host wires to, the host modules, and the host test suites in one
+# sx_server process, then reports pass/fail per suite. Mirrors lib/dream's runner.
+#
+# Usage:
+#   bash lib/host/conformance.sh        # run all suites
+#   bash lib/host/conformance.sh -v     # verbose (list each suite)
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="/root/rose-ash/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
+
+VERBOSE="${1:-}"
+
+# Kernel + subsystem dependencies, then the host modules. Order matters:
+# stdlib/r7rs first; the Datalog engine + ACL subsystem (authorisation); the feed
+# subsystem (the first migrated domain); Dream (types/json/auth/error/router) the
+# host builds on; then the host layer itself.
+MODULES=(
+  "spec/stdlib.sx"
+  "lib/r7rs.sx"
+  "lib/apl/runtime.sx"
+  "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"
+  "lib/relations/schema.sx"
+  "lib/relations/engine.sx"
+  "lib/relations/api.sx"
+  "lib/relations/explain.sx"
+  "lib/relations/federation.sx"
+  "lib/relations/tree.sx"
+  "lib/feed/normalize.sx"
+  "lib/feed/stream.sx"
+  "lib/feed/api.sx"
+  "lib/persist/event.sx"
+  "lib/persist/backend.sx"
+  "lib/persist/log.sx"
+  "lib/persist/kv.sx"
+  "lib/persist/api.sx"
+  "lib/persist/durable.sx"
+  "spec/render.sx"
+  "web/adapter-html.sx"
+  "lib/dream/types.sx"
+  "lib/dream/json.sx"
+  "lib/dream/auth.sx"
+  "lib/dream/error.sx"
+  "lib/dream/form.sx"
+  "lib/dream/router.sx"
+  "lib/host/handler.sx"
+  "lib/host/middleware.sx"
+  "lib/host/sxtp.sx"
+  "lib/host/router.sx"
+  "lib/host/feed.sx"
+  "lib/host/relations.sx"
+  "lib/host/blog.sx"
+  "lib/host/page.sx"
+  "lib/host/server.sx"
+  "lib/host/ledger.sx"
+)
+
+# Suites: NAME RUNNER-FN PATH
+SUITES=(
+  "handler     host-hd-tests-run!  lib/host/tests/handler.sx"
+  "middleware  host-mw-tests-run!  lib/host/tests/middleware.sx"
+  "sxtp        host-sx-tests-run!  lib/host/tests/sxtp.sx"
+  "router      host-rt-tests-run!  lib/host/tests/router.sx"
+  "feed        host-fd-tests-run!  lib/host/tests/feed.sx"
+  "relations   host-rl-tests-run!  lib/host/tests/relations.sx"
+  "blog        host-bl-tests-run!  lib/host/tests/blog.sx"
+  "page        host-pg-tests-run!  lib/host/tests/page.sx"
+  "server      host-sv-tests-run!  lib/host/tests/server.sx"
+  "ledger      host-lg-tests-run!  lib/host/tests/ledger.sx"
+)
+
+TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
+EPOCH=1
+emit_load () { echo "(epoch $EPOCH)"; echo "(load \"$1\")"; EPOCH=$((EPOCH+1)); }
+emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); }
+
+{
+  for M in "${MODULES[@]}"; do emit_load "$M"; done
+  for SUITE in "${SUITES[@]}"; do
+    read -r _NAME _RUNNER FILE <<< "$SUITE"
+    emit_load "$FILE"
+    emit_eval "($_RUNNER)"
+  done
+} > "$TMPFILE"
+
+OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
+
+# Fail LOUD on any load/eval error. A test file that errors mid-load silently
+# truncates its suite — the runner returns only the tests that ran before the
+# error, so the suite reports a false green (e.g. "blog 13 passed, 0 failed"
+# when 16 CRUD tests never ran). Catch the error markers and abort before the
+# pass/fail tally can hide them.
+if echo "$OUTPUT" | grep -qE 'Undefined symbol|Unhandled exception|\[load\][^|]*[Ee]rror|expected list, got|: error '; then
+  echo "FAIL: load/eval error detected — a suite may be silently truncated:" >&2
+  echo "$OUTPUT" | grep -nE 'Undefined symbol|Unhandled exception|\[load\]|expected list, got|: error ' | head -20 >&2
+  exit 1
+fi
+
+TOTAL_PASS=0
+TOTAL_FAIL=0
+FAILED_SUITES=()
+LAST_DICT_LINES=$(echo "$OUTPUT" | grep -E '^\{:' || true)
+
+I=0
+while read -r LINE; do
+  [ -z "$LINE" ] && continue
+  P=$(echo "$LINE" | grep -oE ':passed [0-9]+' | awk '{print $2}')
+  F=$(echo "$LINE" | grep -oE ':failed [0-9]+' | awk '{print $2}')
+  [ -z "$P" ] && P=0
+  [ -z "$F" ] && F=0
+  SUITE_INFO="${SUITES[$I]}"
+  SUITE_NAME=$(echo "$SUITE_INFO" | awk '{print $1}')
+  TOTAL_PASS=$((TOTAL_PASS + P))
+  TOTAL_FAIL=$((TOTAL_FAIL + F))
+  if [ "$F" -gt 0 ]; then
+    FAILED_SUITES+=("$SUITE_NAME: $P/$((P+F))")
+    printf 'X %-12s %d/%d\n' "$SUITE_NAME" "$P" "$((P+F))"
+    echo "$LINE" | grep -oE ':name "[^"]*"' | sed 's/:name /    fail: /'
+  elif [ "$VERBOSE" = "-v" ]; then
+    printf 'ok %-12s %d passed\n' "$SUITE_NAME" "$P"
+  fi
+  I=$((I+1))
+done <<< "$LAST_DICT_LINES"
+
+TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
+if [ "$TOTAL" -eq 0 ]; then
+  echo "ERROR: no suite results parsed. Raw output:" >&2
+  echo "$OUTPUT" >&2
+  exit 1
+fi
+if [ $TOTAL_FAIL -eq 0 ]; then
+  echo "ok $TOTAL_PASS/$TOTAL host-on-sx tests passed (${#SUITES[@]} suites)"
+else
+  echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed:"
+  for S in "${FAILED_SUITES[@]}"; do echo "  $S"; done
+  exit 1
+fi

lib/host/feed.sx

@@ -0,0 +1,49 @@
+;; lib/host/feed.sx — Feed domain endpoints on the host. The first domain migrated
+;; onto the SX host: read the activity timeline (GET /feed) and create activities
+;; (POST /feed). Both go straight through the feed subsystem's public API; the
+;; write path runs behind the host middleware stack (auth + ACL). Depends on
+;; lib/feed/* + lib/host/handler.sx + lib/host/middleware.sx (write routes only).
+
+;; ── read ───────────────────────────────────────────────────────────
+
+;; GET /feed -> recent-first activities as a JSON envelope.
+;; Query: ?actor=<id> (filter) ?limit=<n> (cap, applied after filtering).
+(define host/feed-timeline
+  (fn (req)
+    (let ((base (feed/recent (feed/all)))
+          (actor (dream-query-param req "actor")))
+      (let ((filtered (if actor (feed/by-actor base actor) base))
+            (limit (dream-query-param req "limit")))
+        (let ((capped
+                (if limit (feed/take filtered (string->number limit)) filtered)))
+          (host/ok (feed/items capped)))))))
+
+;; Public read route group.
+(define host/feed-routes
+  (list
+    (dream-get "/feed" host/feed-timeline)))
+
+;; ── write ──────────────────────────────────────────────────────────
+
+;; POST /feed -> create an activity from the JSON body. Returns 201 + the created
+;; (normalised) activity. Body must be a JSON object; anything else -> 400.
+(define host/feed-create
+  (fn (req)
+    (let ((raw (dream-json-body req)))
+      (if (= (type-of raw) "dict")
+        (host/ok-status 201 (feed/post raw))
+        (host/error 400 "invalid activity")))))
+
+;; Guarded write route group: POST /feed behind auth + ACL ("post" on "feed").
+;; resolve : token -> principal | nil (injected auth policy, e.g. token lookup
+;; against the identity subsystem). Errors thrown downstream become a JSON 500.
+(define host/feed-write-routes
+  (fn (resolve)
+    (list
+      (dream-post "/feed"
+        (host/pipeline
+          (list
+            host/wrap-errors
+            (host/require-auth resolve)
+            (host/require-permission "post" (fn (req) "feed")))
+          host/feed-create)))))

lib/host/handler.sx

@@ -0,0 +1,39 @@
+;; lib/host/handler.sx — Host handler layer: the bridge from a Dream request to a
+;; subsystem call and back to a Dream response. A host handler IS a Dream handler
+;; (request -> response); these helpers build the JSON envelope every host
+;; endpoint shares: {"ok":true,"data":...} on success, {"ok":false,"error":...}
+;; on failure. Plus a status-carrying JSON constructor that Dream's own dream-json
+;; (200-only) lacks, and a couple of request-reading conveniences.
+;; Depends on lib/dream/types.sx + lib/dream/json.sx.
+
+;; ── responses ──────────────────────────────────────────────────────
+
+;; JSON response at an arbitrary status (dream-json is 200-only).
+(define host/json-status
+  (fn (status value)
+    (dream-response status {:content-type "application/json"}
+      (dream-json-encode value))))
+
+;; Success envelope: 200 {"ok":true,"data":<value>}.
+(define host/ok
+  (fn (value)
+    (host/json-status 200 {:ok true :data value})))
+
+;; Success envelope at a chosen status (e.g. 201 for a created resource).
+(define host/ok-status
+  (fn (status value)
+    (host/json-status status {:ok true :data value})))
+
+;; Error envelope: {"ok":false,"error":<message>} at the given status.
+(define host/error
+  (fn (status message)
+    (host/json-status status {:ok false :error message})))
+
+;; ── request reading ────────────────────────────────────────────────
+
+;; Integer query param with a fallback (query params arrive as strings).
+;; Absent param -> fallback; present -> parsed number.
+(define host/query-int
+  (fn (req name fallback)
+    (let ((raw (dream-query-param req name)))
+      (if raw (string->number raw) fallback))))

lib/host/ledger.sx

@@ -0,0 +1,89 @@
+;; lib/host/ledger.sx — the strangler migration ledger. A catalogue of every
+;; rose-ash HTTP endpoint with its Quart original and its current host status, so
+;; the cut-over from Quart to the SX host is tracked endpoint-by-endpoint rather
+;; than big-bang. Status is one of:
+;;   :native   — born on the host, has no Quart original (e.g. /health probe)
+;;   :migrated — moved off Quart, now served by an SX handler
+;;   :proxied  — still on Quart; the host forwards until cut over
+;; Coverage (how far the strangler has progressed = how much is OFF Quart) is
+;; computed from the catalogue. Pure data + queries — no IO, fully conformable.
+
+;; ── entry constructor ───────────────────────────────────────────────
+;; quart is a "service:handler" ref string (nil for :native endpoints); handler
+;; is the SX handler name serving it (nil while still :proxied).
+(define host/ledger-entry
+  (fn (domain method path quart status handler)
+    {:domain domain :method method :path path
+     :quart quart :status status :handler handler}))
+
+;; ── the catalogue ───────────────────────────────────────────────────
+;; Reflects the live host: feed reads+writes migrated, /health native, the
+;; relations container endpoints migrated onto lib/relations (reads get-children/
+;; get-parents + writes attach-child/detach-child — see lib/host/relations.sx).
+;; The TYPED relations actions (relate/unrelate/can-relate) stay proxied: they
+;; carry registry + cardinality validation lib/relations does not implement. The
+;; internal-only likes data+action endpoints stay proxied too — likes has no SX
+;; subsystem to dispatch to.
+(define host/ledger
+  (list
+    (host/ledger-entry "host"      "GET"  "/health"                     nil                         "native"   "host/health-route")
+    (host/ledger-entry "blog"      "GET"  "/:slug"                      "blog:post_detail"          "migrated" "host/blog-post")
+    (host/ledger-entry "feed"      "GET"  "/feed"                       "feed:timeline"             "migrated" "host/feed-timeline")
+    (host/ledger-entry "feed"      "POST" "/feed"                       "feed:create"               "migrated" "host/feed-create")
+    (host/ledger-entry "relations" "GET"  "/internal/data/get-children"  "relations:get_children"  "migrated" "host/relations-children")
+    (host/ledger-entry "relations" "GET"  "/internal/data/get-parents"   "relations:get_parents"   "migrated" "host/relations-parents")
+    (host/ledger-entry "relations" "POST" "/internal/actions/attach-child" "relations:attach_child" "migrated" "host/relations-attach")
+    (host/ledger-entry "relations" "POST" "/internal/actions/detach-child" "relations:detach_child" "migrated" "host/relations-detach")
+    (host/ledger-entry "relations" "POST" "/internal/actions/relate"     "relations:relate"        "proxied"  nil)
+    (host/ledger-entry "relations" "POST" "/internal/actions/unrelate"   "relations:unrelate"      "proxied"  nil)
+    (host/ledger-entry "relations" "POST" "/internal/actions/can-relate" "relations:can_relate"    "proxied"  nil)
+    (host/ledger-entry "likes"     "GET"  "/internal/data/is-liked"     "likes:is_liked"            "proxied"  nil)
+    (host/ledger-entry "likes"     "GET"  "/internal/data/liked-slugs"  "likes:liked_slugs"         "proxied"  nil)
+    (host/ledger-entry "likes"     "GET"  "/internal/data/liked-ids"    "likes:liked_ids"           "proxied"  nil)
+    (host/ledger-entry "likes"     "POST" "/internal/actions/toggle"    "likes:toggle"              "proxied"  nil)))
+
+;; ── status / domain queries ─────────────────────────────────────────
+(define host/ledger-by-status
+  (fn (ledger status) (filter (fn (e) (= (get e :status) status)) ledger)))
+(define host/ledger-migrated (fn (ledger) (host/ledger-by-status ledger "migrated")))
+(define host/ledger-proxied  (fn (ledger) (host/ledger-by-status ledger "proxied")))
+(define host/ledger-native   (fn (ledger) (host/ledger-by-status ledger "native")))
+(define host/ledger-by-domain
+  (fn (ledger domain) (filter (fn (e) (= (get e :domain) domain)) ledger)))
+
+;; An endpoint is OFF Quart (served by the host) iff native or migrated.
+(define host/ledger-served?
+  (fn (e) (or (= (get e :status) "native") (= (get e :status) "migrated"))))
+
+;; First entry matching (method, path), or nil.
+(define host/ledger-find
+  (fn (ledger method path)
+    (let ((hits (filter
+                  (fn (e) (and (= (get e :method) method) (= (get e :path) path)))
+                  ledger)))
+      (if (> (len hits) 0) (first hits) nil))))
+
+;; Distinct domains in the catalogue (order: first-seen, reversed by cons).
+(define host/ledger-domains
+  (fn (ledger)
+    (reduce
+      (fn (acc e)
+        (let ((d (get e :domain)))
+          (if (some (fn (x) (= x d)) acc) acc (cons d acc))))
+      (list)
+      ledger)))
+
+;; ── coverage ────────────────────────────────────────────────────────
+;; served = off Quart (migrated + native); percent = served / total, floored.
+(define host/ledger-coverage
+  (fn (ledger)
+    (let ((total (len ledger))
+          (migrated (len (host/ledger-migrated ledger)))
+          (proxied (len (host/ledger-proxied ledger)))
+          (native (len (host/ledger-native ledger))))
+      {:total total
+       :migrated migrated
+       :proxied proxied
+       :native native
+       :served (+ migrated native)
+       :percent (if (= total 0) 0 (quotient (* 100 (+ migrated native)) total))})))

lib/host/middleware.sx

@@ -0,0 +1,54 @@
+;; lib/host/middleware.sx — Host middleware: composable handler->handler layers
+;; for the cross-cutting concerns every write endpoint shares — error trapping
+;; (JSON 500), authentication (bearer token -> principal), and authorisation
+;; (ACL permit?). Middleware is plain function composition; host/pipeline threads a
+;; list onto a handler, FIRST middleware outermost (so it runs first). Auth and
+;; permission policy are INJECTED — the token resolver and the resource extractor —
+;; so this layer carries no hardcoded policy. Reuses Dream's bearer/error helpers
+;; and lib/acl's public acl/permit?.
+;; Depends on lib/dream/{auth,error,router}.sx + lib/acl/api.sx + lib/host/handler.sx.
+
+;; Compose a list of middlewares onto a handler (first = outermost).
+(define host/pipeline
+  (fn (middlewares handler)
+    (dr/apply-middlewares middlewares handler)))
+
+;; The authenticated principal attached by host/require-auth.
+(define host/principal (fn (req) (dream-principal req)))
+
+;; ── error trapping ─────────────────────────────────────────────────
+;; Any error thrown downstream becomes a JSON 500 envelope.
+(define host/-on-error
+  (fn (req e) (host/error 500 "internal error")))
+(define host/wrap-errors (dream-catch-with host/-on-error))
+
+;; ── authentication ─────────────────────────────────────────────────
+;; resolve : token -> principal | nil. Missing/invalid token -> JSON 401 with a
+;; WWW-Authenticate: Bearer challenge; success attaches :dream-principal so
+;; downstream layers (and host/principal) can read it.
+(define host/require-auth
+  (fn (resolve)
+    (fn (next)
+      (fn (req)
+        (let ((tok (dream-bearer-token req)))
+          (let ((principal (if tok (resolve tok) nil)))
+            (if (nil? principal)
+              (dream-add-header
+                (host/error 401 "unauthorized")
+                "www-authenticate"
+                "Bearer")
+              (next (assoc req :dream-principal principal)))))))))
+
+;; ── authorisation ──────────────────────────────────────────────────
+;; Gate on ACL: the authed principal must be permitted `action` on the resource
+;; computed by res-fn from the request. Denied -> JSON 403. Assumes the ACL fact
+;; db was loaded (acl/load!) at startup. Place AFTER host/require-auth.
+(define host/require-permission
+  (fn (action res-fn)
+    (fn (next)
+      (fn (req)
+        (let ((subject (host/principal req))
+              (resource (res-fn req)))
+          (if (acl/permit? subject action resource)
+            (next req)
+            (host/error 403 "forbidden")))))))

lib/host/page.sx

@@ -0,0 +1,22 @@
+;; lib/host/page.sx — serve interactive SX component/island pages on the host
+;; (Phase 5: the generic interactive-SX-page capability).
+;;
+;; The bare `render-to-html` path mangles an EVALUATED component tree's keyword
+;; attributes ((form :id ..) -> "<form>idpost-new-form..."), because evaluating a
+;; defcomp body turns `:id` into a child. The kernel `render-page` primitive
+;; instead renders an UNEVALUATED expression with the server env: render-to-html
+;; expands the components itself and collects keyword args as attributes. SX
+;; handlers can't reach the server env, so render-page supplies it.
+;;
+;; host/page wraps a rendered expression as an HTML response; host/page-route
+;; mounts it on a GET path. This is the component-render step (5.1); the full page
+;; shell (inlined component defs + CSS + client runtime + hydration) and static
+;; asset serving (5.2–5.4) build on top to make the page interactive.
+;; Depends on the kernel `render-page` primitive + lib/dream/types.sx (dream-html).
+
+;; Render an unevaluated SX page/component expression to an HTML response.
+(define host/page (fn (expr) (dream-html (render-page expr))))
+
+;; Mount a GET route that renders a fixed page expression.
+(define host/page-route
+  (fn (path expr) (dream-get path (fn (req) (host/page expr)))))

lib/host/relations.sx

@@ -0,0 +1,132 @@
+;; lib/host/relations.sx — Relations domain endpoints on the host. The relations
+;; service is internal-only (no public routes): Quart exposes it as signed
+;; /internal/data/{query} reads + /internal/actions/{action} writes. This migrates
+;; the two READ queries — get-children, get-parents — straight onto the SX host,
+;; dispatching to the lib/relations subsystem (a saturating Datalog graph).
+;;
+;; Node model: the Quart relations API keys nodes by a (type, id) pair; the graph
+;; subsystem keys them by an opaque atom. We bridge by composing the atom as the
+;; symbol "type:id", with the relation-type as the edge kind. Optional child-type
+;; / parent-type params filter the result by that "type:" prefix — matching the
+;; Quart queries' optional type narrowing.
+;; Depends on lib/relations/* + lib/host/handler.sx + lib/dream/* (query params).
+
+;; ── node helpers ────────────────────────────────────────────────────
+(define host/-rel-node
+  (fn (type id) (string->symbol (str type ":" id))))
+(define host/-rel-node-type?
+  (fn (node type) (starts-with? (symbol->string node) (str type ":"))))
+(define host/-rel-strings
+  (fn (nodes) (map (fn (n) (symbol->string n)) nodes)))
+
+;; ── GET /internal/data/get-children ─────────────────────────────────
+;; query: parent-type, parent-id, relation-type (required); child-type (optional
+;; filter). Returns the child node ids ("type:id") for the parent under that kind.
+(define host/relations-children
+  (fn (req)
+    (let ((ptype (dream-query-param req "parent-type"))
+          (pid (dream-query-param req "parent-id"))
+          (kind (dream-query-param req "relation-type")))
+      (if (and ptype pid kind)
+        (let ((kids (relations/children (host/-rel-node ptype pid) (string->symbol kind)))
+              (ctype (dream-query-param req "child-type")))
+          (let ((sel (if ctype (filter (fn (k) (host/-rel-node-type? k ctype)) kids) kids)))
+            (host/ok (host/-rel-strings sel))))
+        (host/error 400 "missing parameter")))))
+
+;; ── GET /internal/data/get-parents ──────────────────────────────────
+;; query: child-type, child-id, relation-type (required); parent-type (optional
+;; filter). Returns the parent node ids ("type:id") for the child under that kind.
+(define host/relations-parents
+  (fn (req)
+    (let ((ctype (dream-query-param req "child-type"))
+          (cid (dream-query-param req "child-id"))
+          (kind (dream-query-param req "relation-type")))
+      (if (and ctype cid kind)
+        (let ((ps (relations/parents (host/-rel-node ctype cid) (string->symbol kind)))
+              (ptype (dream-query-param req "parent-type")))
+          (let ((sel (if ptype (filter (fn (p) (host/-rel-node-type? p ptype)) ps) ps)))
+            (host/ok (host/-rel-strings sel))))
+        (host/error 400 "missing parameter")))))
+
+;; ── read route group ────────────────────────────────────────────────
+;; Internal data reads (the signed-internal-auth gate is a separate middleware
+;; concern, like the feed reads); these dispatch straight to the subsystem.
+(define host/relations-routes
+  (list
+    (dream-get "/internal/data/get-children" host/relations-children)
+    (dream-get "/internal/data/get-parents" host/relations-parents)))
+
+;; ── writes: container relations (attach-child / detach-child) ────────
+;; The write side of get-children/get-parents: a container edge between a parent
+;; (type,id) and child (type,id) under a relation kind. Maps to relations/relate
+;; and relations/unrelate over the same "type:id" node model, so an attach is
+;; immediately visible through get-children. (The TYPED relate/unrelate/can-relate
+;; actions stay on Quart — they carry registry + cardinality validation that
+;; lib/relations does not implement.) Body is the action's JSON params dict.
+
+;; Pull the four node coordinates + kind from a payload; nil if any are absent.
+(define host/-rel-edge
+  (fn (p)
+    (let ((pt (get p :parent-type)) (pid (get p :parent-id))
+          (ct (get p :child-type)) (cid (get p :child-id))
+          (kind (get p :relation-type)))
+      (if (and pt pid ct cid kind)
+        {:parent (host/-rel-node pt pid)
+         :child (host/-rel-node ct cid)
+         :kind (string->symbol kind)
+         :parent-id (str pt ":" pid)
+         :child-id (str ct ":" cid)
+         :relation kind}
+        nil))))
+
+;; POST /internal/actions/attach-child — create the container edge. 201 on success.
+(define host/relations-attach
+  (fn (req)
+    (let ((p (dream-json-body req)))
+      (if (= (type-of p) "dict")
+        (let ((e (host/-rel-edge p)))
+          (if e
+            (begin
+              (relations/relate (get e :parent) (get e :child) (get e :kind))
+              (host/ok-status 201
+                {:parent (get e :parent-id) :child (get e :child-id)
+                 :relation (get e :relation)}))
+            (host/error 400 "missing parameter")))
+        (host/error 400 "invalid payload")))))
+
+;; POST /internal/actions/detach-child — remove the container edge. 200 on success.
+(define host/relations-detach
+  (fn (req)
+    (let ((p (dream-json-body req)))
+      (if (= (type-of p) "dict")
+        (let ((e (host/-rel-edge p)))
+          (if e
+            (begin
+              (relations/unrelate (get e :parent) (get e :child) (get e :kind))
+              (host/ok
+                {:parent (get e :parent-id) :child (get e :child-id)
+                 :relation (get e :relation) :detached true}))
+            (host/error 400 "missing parameter")))
+        (host/error 400 "invalid payload")))))
+
+;; Guarded write route group: each action behind auth + ACL. attach needs
+;; ("relate","relations"); detach needs ("unrelate","relations"). resolve is the
+;; injected token->principal auth policy (same shape as host/feed-write-routes).
+(define host/relations-write-routes
+  (fn (resolve)
+    (list
+      (dream-post "/internal/actions/attach-child"
+        (host/pipeline
+          (list
+            host/wrap-errors
+            (host/require-auth resolve)
+            (host/require-permission "relate" (fn (req) "relations")))
+          host/relations-attach))
+      (dream-post "/internal/actions/detach-child"
+        (host/pipeline
+          (list
+            host/wrap-errors
+            (host/require-auth resolve)
+            (host/require-permission "unrelate" (fn (req) "relations")))
+          host/relations-detach)))))

lib/host/router.sx

@@ -0,0 +1,19 @@
+;; lib/host/router.sx — Host application assembly. A host app is a single Dream
+;; router built from per-domain route groups, with a built-in health endpoint and
+;; a JSON 404 fallback so the native OCaml HTTP server has one entry point:
+;; request -> response. Each subsystem contributes a list of Dream routes (see
+;; lib/host/feed.sx); host/make-app concatenates them under one router.
+;; dr/flatten-routes (Dream) flattens the nested groups, so a group is just a list
+;; of routes. Depends on lib/dream/router.sx + lib/host/handler.sx.
+
+;; Liveness probe — GET /health -> 200 {"ok":true,"data":"healthy"}.
+(define host/health-route
+  (dream-get "/health" (fn (req) (host/ok "healthy"))))
+
+;; Build the host app from a list of route groups (each a list of Dream routes).
+;; The health route is always mounted first; Dream's router returns a JSON-free
+;; 404 for unmatched paths, which host endpoints override per-domain as needed.
+(define host/make-app
+  (fn (groups)
+    (dream-router
+      (cons host/health-route groups))))

lib/host/serve.sh

@@ -0,0 +1,110 @@
+#!/usr/bin/env bash
+# host-on-sx live server launcher. Loads the kernel stdlib, the subsystem
+# libraries, and the host modules into one sx_server process, then calls
+# (host/serve PORT ...) which binds the native http-listen server to the
+# Dream-shaped host app. Runs in the FOREGROUND (http-listen blocks), so this
+# doubles as a container entrypoint and a local launcher.
+#
+# Usage:
+#   bash lib/host/serve.sh                 # serve on $HOST_PORT (default 8910)
+#   HOST_PORT=8920 bash lib/host/serve.sh  # pick a port
+#
+# The module list is kept identical to lib/host/conformance.sh so what serves is
+# exactly what the suites verify.
+
+set -uo pipefail
+# Project root: SX_PROJECT_DIR in containers (set to /app by the compose stack),
+# else the git toplevel for local runs.
+cd "${SX_PROJECT_DIR:-$(git rev-parse --show-toplevel 2>/dev/null || echo .)}"
+
+SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="/root/rose-ash/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
+
+PORT="${HOST_PORT:-8910}"
+
+# Modules: every load line from conformance.sh's MODULES list, minus the ledger
+# (not needed to serve). server.sx supplies host/serve.
+MODULES=(
+  "spec/stdlib.sx"
+  "lib/r7rs.sx"
+  "lib/apl/runtime.sx"
+  "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"
+  "lib/relations/schema.sx"
+  "lib/relations/engine.sx"
+  "lib/relations/api.sx"
+  "lib/relations/explain.sx"
+  "lib/relations/federation.sx"
+  "lib/relations/tree.sx"
+  "lib/feed/normalize.sx"
+  "lib/feed/stream.sx"
+  "lib/feed/api.sx"
+  "lib/persist/event.sx"
+  "lib/persist/backend.sx"
+  "lib/persist/log.sx"
+  "lib/persist/kv.sx"
+  "lib/persist/api.sx"
+  "lib/persist/durable.sx"
+  "spec/render.sx"
+  "web/adapter-html.sx"
+  "lib/dream/types.sx"
+  "lib/dream/json.sx"
+  "lib/dream/auth.sx"
+  "lib/dream/error.sx"
+  "lib/dream/form.sx"
+  "lib/dream/router.sx"
+  "lib/host/handler.sx"
+  "lib/host/middleware.sx"
+  "lib/host/sxtp.sx"
+  "lib/host/router.sx"
+  "lib/host/feed.sx"
+  "lib/host/relations.sx"
+  "lib/host/blog.sx"
+  "lib/host/server.sx"
+)
+
+EPOCH=1
+{
+  for M in "${MODULES[@]}"; do
+    echo "(epoch $EPOCH)"; echo "(load \"$M\")"; EPOCH=$((EPOCH+1))
+  done
+  # Point the blog at the DURABLE file backend (persists under $SX_PERSIST_DIR),
+  # then idempotently seed a welcome post (sx_content = SX element markup, the
+  # editor's content model). Re-seeding is a no-op if the slug already exists.
+  echo "(epoch $EPOCH)"
+  echo "(eval \"(host/blog-use-store! (persist/durable-backend))\")"
+  EPOCH=$((EPOCH+1))
+  echo "(epoch $EPOCH)"
+  echo "(eval \"(host/blog-seed! \\\"welcome\\\" \\\"Welcome to the SX host\\\" \\\"(article (h1 \\\\\\\"Welcome to the SX host\\\\\\\") (p \\\\\\\"Rendered by lib/host via render-to-html, from the durable SX store.\\\\\\\"))\\\" \\\"published\\\")\")"
+  EPOCH=$((EPOCH+1))
+  echo "(epoch $EPOCH)"
+  # Anonymous read endpoints: feed timeline + relations container reads + blog
+  # post detail (blog-routes LAST — the :slug catch-all must not shadow the rest).
+  # Guarded write groups (auth/ACL or internal-HMAC) are added here once their
+  # injected policy is supplied at wiring time.
+  # EXPERIMENTAL: host/blog-open-create-routes mounts POST /new UNGUARDED (no
+  # auth) so the editor can publish end-to-end on the experimental subdomain.
+  # Create-only (no PUT/DELETE). GATE (Caddy basicauth / sessions) before real use.
+  echo "(eval \"(host/serve $PORT (list host/feed-routes host/relations-routes host/blog-open-create-routes host/blog-routes))\")"
+} | exec "$SX_SERVER"

lib/host/server.sx

@@ -0,0 +1,44 @@
+;; lib/host/server.sx — the live wiring: bridge the native OCaml http-listen
+;; server to the Dream-shaped host app, and serve. The native server hands a
+;; handler a STRING-keyed request dict {"method" "path" "query" "headers" "body"}
+;; and expects back {:status :headers :body}. The host app (host/make-app ->
+;; dream-router) is a fn dream-request -> dream-response. This module adapts
+;; between the two shapes and calls http-listen.
+;; Depends on lib/dream/* (dream-request/response accessors) + lib/host/router.sx
+;; + the kernel http-listen primitive.
+
+;; ── native request -> dream request ─────────────────────────────────
+;; Reassemble path + query into the target string dream-request parses, and carry
+;; method/headers/body. Missing fields default empty.
+(define host/-native->dream
+  (fn (req)
+    (let ((path (or (get req "path") "/"))
+          (query (or (get req "query") ""))
+          (method (or (get req "method") "GET"))
+          (headers (or (get req "headers") {}))
+          (body (or (get req "body") "")))
+      (let ((target (if (> (len query) 0) (str path "?" query) path)))
+        (dream-request method target headers body)))))
+
+;; ── dream response -> native response ───────────────────────────────
+;; dream-response is already {:body :headers :status}; the native server wants
+;; {:status :headers :body}. Same keys — normalise the shape explicitly so the
+;; contract is visible (and headers/body never nil).
+(define host/-dream->native
+  (fn (resp)
+    {:status (dream-status resp)
+     :headers (or (dream-headers resp) {})
+     :body (or (dream-resp-body resp) "")}))
+
+;; ── adapter + serve ─────────────────────────────────────────────────
+;; Wrap a Dream app as a native http-listen handler.
+(define host/native-handler
+  (fn (app)
+    (fn (req)
+      (host/-dream->native (app (host/-native->dream req))))))
+
+;; Build the app from route groups and start the native server on `port`.
+;; Blocks (the http-listen primitive runs the server loop).
+(define host/serve
+  (fn (port groups)
+    (http-listen port (host/native-handler (host/make-app groups)))))

lib/host/sxtp.sx

@@ -0,0 +1,173 @@
+;; lib/host/sxtp.sx — SXTP, the host<->subsystem wire format. SXTP messages are
+;; SX s-expressions (content-type text/sx): a request/response/condition/event is
+;; a tagged list `(request :verb navigate :path "/x" ...)`. See the protocol spec
+;; at applications/sxtp/spec.sx.
+;;
+;; Representation: internally a message is a plain dict tagged by :msg ("request"
+;; /"response"/"condition"/"event"), with string keys so the keyword==string rule
+;; makes construction and access trivial. verb/status/type are stored as SYMBOLS
+;; (they ride the wire bare, not quoted). The wire LIST form is produced/consumed
+;; only at the serialise/parse boundary:
+;;   sxtp/serialize : msg-dict -> text/sx string
+;;   sxtp/parse     : text/sx string -> msg-dict
+;; A Dream HTTP request/response bridges to/from SXTP via sxtp/from-dream and
+;; sxtp/to-dream, so the host can speak SXTP to subsystems while serving HTTP.
+;; Depends on lib/dream/types.sx (dream-response + request/response accessors).
+
+;; ── helpers ────────────────────────────────────────────────────────
+(define sxtp/-sym
+  (fn (x) (if (= (type-of x) "symbol") x (string->symbol x))))
+(define sxtp/-name
+  (fn (x) (if (= (type-of x) "symbol") (symbol->string x) x)))
+
+;; ── constructors ───────────────────────────────────────────────────
+;; opts is a dict of optional fields (e.g. {:headers .. :params .. :body ..}).
+(define sxtp/request
+  (fn (verb path opts)
+    (merge {:msg "request" :verb (sxtp/-sym verb) :path path} opts)))
+(define sxtp/response
+  (fn (status opts)
+    (merge {:msg "response" :status (sxtp/-sym status)} opts)))
+(define sxtp/condition
+  (fn (ctype opts)
+    (merge {:msg "condition" :type (sxtp/-sym ctype)} opts)))
+(define sxtp/event
+  (fn (etype opts)
+    (merge {:msg "event" :type (sxtp/-sym etype)} opts)))
+
+;; ── predicates ─────────────────────────────────────────────────────
+(define sxtp/-is?
+  (fn (m tag) (and (= (type-of m) "dict") (= (get m :msg) tag))))
+(define sxtp/request? (fn (m) (sxtp/-is? m "request")))
+(define sxtp/response? (fn (m) (sxtp/-is? m "response")))
+(define sxtp/condition? (fn (m) (sxtp/-is? m "condition")))
+(define sxtp/event? (fn (m) (sxtp/-is? m "event")))
+
+;; ── accessors ──────────────────────────────────────────────────────
+(define sxtp/verb (fn (m) (get m :verb)))
+(define sxtp/path (fn (m) (get m :path)))
+(define sxtp/req-headers (fn (m) (get m :headers)))
+(define sxtp/params (fn (m) (get m :params)))
+(define sxtp/param (fn (m name) (get (get m :params) name)))
+(define sxtp/body (fn (m) (get m :body)))
+(define sxtp/capabilities (fn (m) (get m :capabilities)))
+(define sxtp/status (fn (m) (get m :status)))
+(define sxtp/resp-headers (fn (m) (get m :headers)))
+(define sxtp/stream? (fn (m) (= (get m :stream) true)))
+(define sxtp/cond-type (fn (m) (get m :type)))
+(define sxtp/cond-message (fn (m) (get m :message)))
+
+;; ── status helpers (build responses) ───────────────────────────────
+(define sxtp/ok (fn (body) (sxtp/response "ok" {:body body})))
+(define sxtp/created (fn (body) (sxtp/response "created" {:body body})))
+(define sxtp/no-content (fn () (sxtp/response "no-content" {})))
+(define sxtp/not-found
+  (fn (path message)
+    (sxtp/response "not-found"
+      {:body (sxtp/condition "resource-not-found"
+               {:path path :message message :retry false})})))
+(define sxtp/forbidden
+  (fn (message)
+    (sxtp/response "forbidden"
+      {:body (sxtp/condition "forbidden" {:message message})})))
+(define sxtp/invalid
+  (fn (message)
+    (sxtp/response "invalid"
+      {:body (sxtp/condition "invalid" {:message message})})))
+(define sxtp/fail
+  (fn (message)
+    (sxtp/response "error"
+      {:body (sxtp/condition "error" {:message message})})))
+
+;; ── HTTP <-> SXTP mappings ─────────────────────────────────────────
+(define sxtp/-method-verbs
+  {:GET "fetch" :HEAD "fetch" :POST "create"
+   :PUT "mutate" :PATCH "mutate" :DELETE "delete" :OPTIONS "inspect"})
+(define sxtp/verb-for-method
+  (fn (method) (sxtp/-sym (get sxtp/-method-verbs (upper method) "fetch"))))
+
+(define sxtp/-status-http
+  {:ok 200 :created 201 :accepted 202 :no-content 204 :redirect 302
+   :not-modified 304 :error 500 :not-found 404 :forbidden 403
+   :invalid 400 :conflict 409 :unavailable 503})
+(define sxtp/http-status
+  (fn (status) (get sxtp/-status-http (sxtp/-name status) 200)))
+
+;; ── Dream bridge ───────────────────────────────────────────────────
+;; HTTP request -> SXTP request: method->verb, query->params, headers/body carry.
+(define sxtp/from-dream
+  (fn (req)
+    (sxtp/request
+      (sxtp/verb-for-method (get req :method))
+      (get req :path)
+      {:headers (get req :headers)
+       :params (get req :query)
+       :body (get req :body)})))
+
+;; SXTP response -> HTTP response: status->code, body serialised to text/sx.
+(define sxtp/-body-text
+  (fn (b) (if (nil? b) "" (serialize b))))
+(define sxtp/to-dream
+  (fn (resp)
+    (dream-response
+      (sxtp/http-status (sxtp/status resp))
+      (merge {:content-type "text/sx"} (or (sxtp/resp-headers resp) {}))
+      (sxtp/-body-text (sxtp/body resp)))))
+
+;; ── wire serialise (msg-dict -> text/sx) ───────────────────────────
+;; Top-level field order is fixed per message type so output is deterministic;
+;; nested dict/value order follows the serialize primitive.
+(define sxtp/-field-order
+  {:request (list :verb :path :headers :cookies :params :capabilities :body)
+   :response (list :status :headers :set-cookie :body :stream)
+   :condition (list :type :message :path :retry :detail)
+   :event (list :type :id :body :time)})
+;; A nested SXTP message (a condition/event in a :body) serialises in its own
+;; list form; plain data values go through the serialize primitive.
+(define sxtp/-emit-value
+  (fn (v)
+    (if (and (= (type-of v) "dict") (has-key? v :msg))
+      (sxtp/serialize v)
+      (serialize v))))
+(define sxtp/serialize
+  (fn (msg)
+    (let ((head (get msg :msg)))
+      (let ((order (get sxtp/-field-order head)))
+        (str "("
+          head
+          (reduce
+            (fn (acc k)
+              (if (has-key? msg k)
+                (str acc " :" k " " (sxtp/-emit-value (get msg k)))
+                acc))
+            ""
+            order)
+          ")")))))
+
+;; ── wire parse (text/sx -> msg-dict) ───────────────────────────────
+;; parse yields a list with keyword-token keys and possibly keyword-token dict
+;; keys; sxtp/-normalize deep-converts those tokens to strings so the result is
+;; the same string-keyed shape the constructors produce.
+(define sxtp/-normalize
+  (fn (v)
+    (let ((t (type-of v)))
+      (cond
+        ((= t "keyword") (str v))
+        ((= t "dict")
+          (reduce
+            (fn (acc k) (assoc acc (str k) (sxtp/-normalize (get v k))))
+            {}
+            (keys v)))
+        ((= t "list") (map sxtp/-normalize v))
+        (true v)))))
+(define sxtp/-pairs->dict
+  (fn (kvs acc)
+    (if (< (len kvs) 2)
+      acc
+      (sxtp/-pairs->dict
+        (rest (rest kvs))
+        (assoc acc (str (first kvs)) (sxtp/-normalize (first (rest kvs))))))))
+(define sxtp/parse
+  (fn (text)
+    (let ((lst (parse text)))
+      (sxtp/-pairs->dict (rest lst) {:msg (symbol->string (first lst))}))))

lib/host/tests/blog.sx

@@ -0,0 +1,142 @@
+;; lib/host/tests/blog.sx — blog on the editor's content model. Posts are
+;; {slug,title,sx_content,status} records in the durable KV; a post page is
+;; render-to-html(parse sx_content). Covers read/render, home index, JSON list,
+;; slugify, the form-urlencoded editor ingest, and JSON CRUD (auth+ACL guarded).
+
+(define host-bl-pass 0)
+(define host-bl-fail 0)
+(define host-bl-fails (list))
+(define
+  host-bl-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! host-bl-pass (+ host-bl-pass 1))
+      (begin
+        (set! host-bl-fail (+ host-bl-fail 1))
+        (append! host-bl-fails {:name name :actual actual :expected expected})))))
+
+(define host-bl-req (fn (target) (dream-request "GET" target {} "")))
+(define host-bl-app (host/make-app (list host/feed-routes host/blog-routes)))
+
+;; ── slugify ─────────────────────────────────────────────────────────
+(host-bl-test "slugify" (host/blog-slugify "Hello World") "hello-world")
+(host-bl-test "slugify trims spaces" (host/blog-slugify "  A  B ") "a-b")
+
+;; ── render a stored post ────────────────────────────────────────────
+(host/blog-use-store! (persist/open))
+(host/blog-put! "hello" "Hello World"
+  "(article (h1 \"Hello World\") (p \"A \" (strong \"bold\") \" word.\"))" "published")
+
+(host-bl-test "post 200" (dream-status (host-bl-app (host-bl-req "/hello/"))) 200)
+(host-bl-test "post content-type html"
+  (contains? (dream-resp-header (host-bl-app (host-bl-req "/hello/")) "content-type") "text/html")
+  true)
+(host-bl-test "post renders sx_content markup"
+  (contains? (dream-resp-body (host-bl-app (host-bl-req "/hello/"))) "<strong>bold</strong>")
+  true)
+(host-bl-test "post title in page"
+  (contains? (dream-resp-body (host-bl-app (host-bl-req "/hello/"))) "<title>Hello World</title>")
+  true)
+
+;; ── home + list ─────────────────────────────────────────────────────
+(host-bl-test "home lists post"
+  (contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) "href=\"/hello/\"")
+  true)
+(host-bl-test "json list shows post"
+  (contains? (dream-resp-body (host-bl-app (host-bl-req "/posts"))) "\"slug\":\"hello\"")
+  true)
+(host-bl-test "GET /new shows form"
+  (contains? (dream-resp-body (host-bl-app (host-bl-req "/new"))) "<form")
+  true)
+
+;; ── unknown + precedence ────────────────────────────────────────────
+(host-bl-test "unknown slug 404" (dream-status (host-bl-app (host-bl-req "/nope/"))) 404)
+(feed/reset!)
+(host-bl-test "/feed not captured by :slug"
+  (contains? (dream-resp-body (host-bl-app (host-bl-req "/feed"))) "\"ok\":true")
+  true)
+
+;; ── writes: editor form ingest + JSON CRUD (auth+ACL) ───────────────
+(acl/load! (list (acl-grant "editor" "edit" "blog")))
+(define host-bl-resolve
+  (fn (tok) (cond ((= tok "good") "editor") ((= tok "weak") "reader") (true nil))))
+(define host-bl-wapp
+  (host/make-app (list (host/blog-write-routes host-bl-resolve) host/blog-routes)))
+(define host-bl-send
+  (fn (method target auth ctype body)
+    (dream-request method target
+      (merge (if auth {:authorization auth} {}) (if ctype {:content-type ctype} {})) body)))
+
+(host/blog-use-store! (persist/open))
+
+;; -- editor form ingest (form-urlencoded, the editor's submit shape) --
+(host-bl-test "form ingest no auth -> 401"
+  (dream-status (host-bl-wapp (host-bl-send "POST" "/new" nil
+    "application/x-www-form-urlencoded" "title=X")))
+  401)
+(host-bl-test "form ingest authed -> 303 redirect"
+  (dream-status (host-bl-wapp (host-bl-send "POST" "/new" "Bearer good"
+    "application/x-www-form-urlencoded"
+    "title=My+First+Post&sx_content=(article+(h1+%22My+First+Post%22)+(p+%22Hi%22))&status=published")))
+  303)
+(host-bl-test "form ingest set Location to the new slug"
+  (dream-resp-header
+    (host-bl-wapp (host-bl-send "POST" "/new" "Bearer good"
+      "application/x-www-form-urlencoded"
+      "title=Another+One&sx_content=(p+%22x%22)&status=published"))
+    "location")
+  "/another-one/")
+(host-bl-test "ingested post renders"
+  (contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "<h1>My First Post</h1>")
+  true)
+
+;; -- JSON CRUD --
+(host-bl-test "json create -> 201"
+  (dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json"
+    "{\"title\":\"Json Post\",\"sx_content\":\"(p \\\"jp\\\")\",\"status\":\"draft\"}")))
+  201)
+(host-bl-test "json create unpermitted -> 403"
+  (dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer weak" "application/json"
+    "{\"title\":\"Nope\"}")))
+  403)
+(host-bl-test "json create duplicate -> 409"
+  (dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json"
+    "{\"slug\":\"json-post\",\"title\":\"Json Post\"}")))
+  409)
+(host-bl-test "json create no title -> 400"
+  (dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json" "{}")))
+  400)
+(host-bl-test "update -> 200"
+  (dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/json-post" "Bearer good" "application/json"
+    "{\"sx_content\":\"(p \\\"edited\\\")\"}")))
+  200)
+(host-bl-test "update changed content"
+  (contains? (dream-resp-body (host-bl-wapp (host-bl-req "/json-post/"))) "edited")
+  true)
+(host-bl-test "update missing -> 404"
+  (dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/ghost" "Bearer good" "application/json" "{}")))
+  404)
+(host-bl-test "delete -> 200"
+  (dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/json-post" "Bearer good" "" "")))
+  200)
+(host-bl-test "deleted -> 404" (dream-status (host-bl-wapp (host-bl-req "/json-post/"))) 404)
+(host-bl-test "delete missing -> 404"
+  (dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/ghost" "Bearer good" "" "")))
+  404)
+
+;; -- experimental unguarded create-only route (POST /new, no auth) --
+(define host-bl-oapp (host/make-app (list host/blog-open-create-routes host/blog-routes)))
+(host/blog-use-store! (persist/open))
+(host-bl-test "open create no auth -> 303"
+  (dream-status (host-bl-oapp (host-bl-send "POST" "/new" nil
+    "application/x-www-form-urlencoded" "title=Open+Post&sx_content=(p+%22o%22)&status=published")))
+  303)
+(host-bl-test "open-created post renders"
+  (contains? (dream-resp-body (host-bl-oapp (host-bl-req "/open-post/"))) "<p>o</p>")
+  true)
+
+(define
+  host-bl-tests-run!
+  (fn ()
+    {:total (+ host-bl-pass host-bl-fail)
+     :passed host-bl-pass :failed host-bl-fail :fails host-bl-fails}))

lib/host/tests/feed.sx

@@ -0,0 +1,139 @@
+;; lib/host/tests/feed.sx — the migrated feed endpoints, GET /feed (read) and
+;; POST /feed (guarded write). Includes a golden test: the host read response
+;; body must equal the feed subsystem's own recent-first stream wrapped in the
+;; standard envelope — the endpoint adds the HTTP/JSON shell and nothing else.
+
+(define host-fd-pass 0)
+(define host-fd-fail 0)
+(define host-fd-fails (list))
+
+(define
+  host-fd-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-fd-pass (+ host-fd-pass 1))
+      (begin
+        (set! host-fd-fail (+ host-fd-fail 1))
+        (append! host-fd-fails {:name name :actual actual :expected expected})))))
+
+(define
+  host-fd-req
+  (fn (target) (dream-request "GET" target {} "")))
+
+(define
+  host-fd-app
+  (host/make-app (list host/feed-routes)))
+
+;; ── empty feed ─────────────────────────────────────────────────────
+(feed/reset!)
+(host-fd-test
+  "empty feed 200"
+  (dream-status (host-fd-app (host-fd-req "/feed")))
+  200)
+(host-fd-test
+  "empty feed data:[]"
+  (contains? (dream-resp-body (host-fd-app (host-fd-req "/feed"))) "\"data\":[]")
+  true)
+
+;; ── seeded feed ────────────────────────────────────────────────────
+(feed/reset!)
+(feed/post {:actor "alice" :verb "post" :object "p1" :at 1})
+(feed/post {:actor "bob" :verb "post" :object "p2" :at 2})
+(feed/post {:actor "alice" :verb "like" :object "p2" :at 3})
+
+;; recent-first: newest activity (at 3) leads, so its marker precedes the oldest.
+(host-fd-test
+  "timeline recent-first"
+  (let ((body (dream-resp-body (host-fd-app (host-fd-req "/feed")))))
+    (< (index-of body "\"at\":3") (index-of body "\"at\":1")))
+  true)
+
+;; actor filter: only alice's two activities.
+(host-fd-test
+  "actor filter count"
+  (feed/count
+    (feed/by-actor (feed/recent (feed/all)) "alice"))
+  2)
+(host-fd-test
+  "actor filter excludes bob"
+  (contains?
+    (dream-resp-body (host-fd-app (host-fd-req "/feed?actor=alice")))
+    "bob")
+  false)
+
+;; limit: cap to a single activity (the most recent).
+(host-fd-test
+  "limit caps results"
+  (contains?
+    (dream-resp-body (host-fd-app (host-fd-req "/feed?limit=1")))
+    "\"at\":1")
+  false)
+
+;; ── golden: endpoint = subsystem recent stream + envelope ───────────
+(host-fd-test
+  "golden full timeline"
+  (dream-resp-body (host-fd-app (host-fd-req "/feed")))
+  (str
+    "{\"ok\":true,\"data\":"
+    (dream-json-encode (feed/items (feed/recent (feed/all))))
+    "}"))
+(host-fd-test
+  "golden actor-filtered"
+  (dream-resp-body (host-fd-app (host-fd-req "/feed?actor=alice")))
+  (str
+    "{\"ok\":true,\"data\":"
+    (dream-json-encode
+      (feed/items (feed/by-actor (feed/recent (feed/all)) "alice")))
+    "}"))
+
+;; ── write: POST /feed (auth + ACL + action) ────────────────────────
+(acl/load! (list (acl-grant "alice" "post" "feed")))
+(define host-fd-resolve (fn (tok) (if (= tok "good") "alice" nil)))
+(define
+  host-fd-wapp
+  (host/make-app
+    (list host/feed-routes (host/feed-write-routes host-fd-resolve))))
+(define
+  host-fd-post
+  (fn (auth body)
+    (dream-request "POST" "/feed" (if auth {:authorization auth} {}) body)))
+
+(feed/reset!)
+(host-fd-test
+  "post no auth -> 401"
+  (dream-status (host-fd-wapp (host-fd-post nil "{}")))
+  401)
+(host-fd-test
+  "post unchanged feed after 401"
+  (feed/size)
+  0)
+(host-fd-test
+  "post authed+permitted -> 201"
+  (dream-status
+    (host-fd-wapp
+      (host-fd-post
+        "Bearer good"
+        "{\"actor\":\"alice\",\"verb\":\"post\",\"object\":\"p9\",\"at\":9}")))
+  201)
+(host-fd-test "post grew feed" (feed/size) 1)
+(host-fd-test
+  "created activity visible in timeline"
+  (contains?
+    (dream-resp-body (host-fd-wapp (host-fd-req "/feed")))
+    "p9")
+  true)
+(host-fd-test
+  "post non-object body -> 400"
+  (dream-status (host-fd-wapp (host-fd-post "Bearer good" "[1,2]")))
+  400)
+
+(define
+  host-fd-tests-run!
+  (fn
+    ()
+    {:total (+ host-fd-pass host-fd-fail)
+     :passed host-fd-pass
+     :failed host-fd-fail
+     :fails host-fd-fails}))

lib/host/tests/handler.sx

@@ -0,0 +1,86 @@
+;; lib/host/tests/handler.sx — host JSON envelope + request-reading helpers.
+
+(define host-hd-pass 0)
+(define host-hd-fail 0)
+(define host-hd-fails (list))
+
+(define
+  host-hd-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-hd-pass (+ host-hd-pass 1))
+      (begin
+        (set! host-hd-fail (+ host-hd-fail 1))
+        (append! host-hd-fails {:name name :actual actual :expected expected})))))
+
+;; ── host/ok ────────────────────────────────────────────────────────
+(host-hd-test "ok status 200" (dream-status (host/ok "x")) 200)
+(host-hd-test
+  "ok content-type json"
+  (dream-resp-header (host/ok "x") "content-type")
+  "application/json")
+(host-hd-test
+  "ok envelope ok:true"
+  (contains? (dream-resp-body (host/ok "x")) "\"ok\":true")
+  true)
+(host-hd-test
+  "ok envelope carries data"
+  (contains? (dream-resp-body (host/ok "hi")) "\"data\":\"hi\"")
+  true)
+
+;; ── host/ok-status ─────────────────────────────────────────────────
+(host-hd-test "ok-status custom" (dream-status (host/ok-status 201 "y")) 201)
+(host-hd-test
+  "ok-status data"
+  (contains? (dream-resp-body (host/ok-status 201 "y")) "\"data\":\"y\"")
+  true)
+
+;; ── host/error ─────────────────────────────────────────────────────
+(host-hd-test "error status" (dream-status (host/error 404 "nope")) 404)
+(host-hd-test
+  "error ok:false"
+  (contains? (dream-resp-body (host/error 404 "nope")) "\"ok\":false")
+  true)
+(host-hd-test
+  "error message"
+  (contains? (dream-resp-body (host/error 404 "nope")) "\"error\":\"nope\"")
+  true)
+(host-hd-test
+  "error content-type json"
+  (dream-resp-header (host/error 500 "boom") "content-type")
+  "application/json")
+
+;; ── host/json-status ───────────────────────────────────────────────
+(host-hd-test
+  "json-status arbitrary status"
+  (dream-status (host/json-status 418 {:a 1}))
+  418)
+(host-hd-test
+  "json-status encodes body"
+  (contains? (dream-resp-body (host/json-status 200 {:a 1})) "\"a\":1")
+  true)
+
+;; ── host/query-int ─────────────────────────────────────────────────
+(define
+  host-hd-req
+  (fn (target) (dream-request "GET" target {} "")))
+
+(host-hd-test
+  "query-int present"
+  (host/query-int (host-hd-req "/x?limit=5") "limit" 10)
+  5)
+(host-hd-test
+  "query-int absent -> fallback"
+  (host/query-int (host-hd-req "/x") "limit" 10)
+  10)
+
+(define
+  host-hd-tests-run!
+  (fn
+    ()
+    {:total (+ host-hd-pass host-hd-fail)
+     :passed host-hd-pass
+     :failed host-hd-fail
+     :fails host-hd-fails}))

lib/host/tests/ledger.sx

@@ -0,0 +1,106 @@
+;; lib/host/tests/ledger.sx — the strangler migration ledger: entry shape,
+;; status/domain queries, find, distinct domains, and coverage maths.
+
+(define host-lg-pass 0)
+(define host-lg-fail 0)
+(define host-lg-fails (list))
+
+(define
+  host-lg-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-lg-pass (+ host-lg-pass 1))
+      (begin
+        (set! host-lg-fail (+ host-lg-fail 1))
+        (append! host-lg-fails {:name name :actual actual :expected expected})))))
+
+;; ── entry constructor ───────────────────────────────────────────────
+(define host-lg-e (host/ledger-entry "feed" "GET" "/feed" "feed:timeline" "migrated" "host/feed-timeline"))
+(host-lg-test "entry domain" (get host-lg-e :domain) "feed")
+(host-lg-test "entry path" (get host-lg-e :path) "/feed")
+(host-lg-test "entry status" (get host-lg-e :status) "migrated")
+(host-lg-test "entry handler" (get host-lg-e :handler) "host/feed-timeline")
+
+;; ── find ────────────────────────────────────────────────────────────
+(host-lg-test
+  "find GET /feed -> migrated"
+  (get (host/ledger-find host/ledger "GET" "/feed") :status)
+  "migrated")
+(host-lg-test
+  "find GET /feed -> handler"
+  (get (host/ledger-find host/ledger "GET" "/feed") :handler)
+  "host/feed-timeline")
+(host-lg-test
+  "find POST /feed -> create"
+  (get (host/ledger-find host/ledger "POST" "/feed") :handler)
+  "host/feed-create")
+(host-lg-test "find missing -> nil" (host/ledger-find host/ledger "GET" "/nope") nil)
+(host-lg-test
+  "find migrated relations read -> handler"
+  (get (host/ledger-find host/ledger "GET" "/internal/data/get-children") :handler)
+  "host/relations-children")
+(host-lg-test
+  "find migrated relations write -> handler"
+  (get (host/ledger-find host/ledger "POST" "/internal/actions/attach-child") :handler)
+  "host/relations-attach")
+(host-lg-test
+  "typed relate still proxied"
+  (get (host/ledger-find host/ledger "POST" "/internal/actions/relate") :status)
+  "proxied")
+
+(host-lg-test
+  "find migrated blog post -> handler"
+  (get (host/ledger-find host/ledger "GET" "/:slug") :handler)
+  "host/blog-post")
+
+;; ── status queries ──────────────────────────────────────────────────
+(host-lg-test "migrated count" (len (host/ledger-migrated host/ledger)) 7)
+(host-lg-test "native count" (len (host/ledger-native host/ledger)) 1)
+(host-lg-test "proxied count" (len (host/ledger-proxied host/ledger)) 7)
+
+;; ── served? predicate ───────────────────────────────────────────────
+(host-lg-test
+  "served? migrated"
+  (host/ledger-served? (host/ledger-find host/ledger "GET" "/feed"))
+  true)
+(host-lg-test
+  "served? native"
+  (host/ledger-served? (host/ledger-find host/ledger "GET" "/health"))
+  true)
+(host-lg-test
+  "served? proxied false"
+  (host/ledger-served? (host/ledger-find host/ledger "POST" "/internal/actions/relate"))
+  false)
+
+;; ── domain queries ──────────────────────────────────────────────────
+(host-lg-test "relations domain count" (len (host/ledger-by-domain host/ledger "relations")) 7)
+(host-lg-test "likes domain count" (len (host/ledger-by-domain host/ledger "likes")) 4)
+(host-lg-test "domains count" (len (host/ledger-domains host/ledger)) 5)
+(host-lg-test
+  "domains has relations"
+  (some (fn (d) (= d "relations")) (host/ledger-domains host/ledger))
+  true)
+(host-lg-test
+  "domains has feed"
+  (some (fn (d) (= d "feed")) (host/ledger-domains host/ledger))
+  true)
+
+;; ── coverage ────────────────────────────────────────────────────────
+(define host-lg-cov (host/ledger-coverage host/ledger))
+(host-lg-test "coverage total" (get host-lg-cov :total) 15)
+(host-lg-test "coverage migrated" (get host-lg-cov :migrated) 7)
+(host-lg-test "coverage proxied" (get host-lg-cov :proxied) 7)
+(host-lg-test "coverage native" (get host-lg-cov :native) 1)
+(host-lg-test "coverage served" (get host-lg-cov :served) 8)
+(host-lg-test "coverage percent" (get host-lg-cov :percent) 53)
+
+(define
+  host-lg-tests-run!
+  (fn
+    ()
+    {:total (+ host-lg-pass host-lg-fail)
+     :passed host-lg-pass
+     :failed host-lg-fail
+     :fails host-lg-fails}))

lib/host/tests/middleware.sx

@@ -0,0 +1,107 @@
+;; lib/host/tests/middleware.sx — auth (bearer -> principal), ACL gate, and error
+;; trapping, composed via host/pipeline. ACL facts: alice may "post" on "feed".
+
+(define host-mw-pass 0)
+(define host-mw-fail 0)
+(define host-mw-fails (list))
+
+(define
+  host-mw-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-mw-pass (+ host-mw-pass 1))
+      (begin
+        (set! host-mw-fail (+ host-mw-fail 1))
+        (append! host-mw-fails {:name name :actual actual :expected expected})))))
+
+;; ── fixtures ───────────────────────────────────────────────────────
+(acl/load! (list (acl-grant "alice" "post" "feed")))
+
+(define host-mw-resolve
+  (fn (tok) (if (= tok "good") "alice" nil)))
+
+(define host-mw-handler
+  (fn (req) (host/ok-status 201 (host/principal req))))
+
+;; protected: needs auth + post/feed permission
+(define host-mw-protected
+  (host/pipeline
+    (list
+      (host/require-auth host-mw-resolve)
+      (host/require-permission "post" (fn (req) "feed")))
+    host-mw-handler))
+
+;; protected with an action alice is NOT granted
+(define host-mw-protected-del
+  (host/pipeline
+    (list
+      (host/require-auth host-mw-resolve)
+      (host/require-permission "delete" (fn (req) "feed")))
+    host-mw-handler))
+
+(define
+  host-mw-req
+  (fn (auth)
+    (dream-request "POST" "/feed"
+      (if auth {:authorization auth} {})
+      "")))
+
+;; ── auth ───────────────────────────────────────────────────────────
+(host-mw-test
+  "no token -> 401"
+  (dream-status (host-mw-protected (host-mw-req nil)))
+  401)
+(host-mw-test
+  "401 has www-authenticate"
+  (dream-resp-header (host-mw-protected (host-mw-req nil)) "www-authenticate")
+  "Bearer")
+(host-mw-test
+  "bad token -> 401"
+  (dream-status (host-mw-protected (host-mw-req "Bearer wrong")))
+  401)
+
+;; ── authz ──────────────────────────────────────────────────────────
+(host-mw-test
+  "authed + permitted -> 201"
+  (dream-status (host-mw-protected (host-mw-req "Bearer good")))
+  201)
+(host-mw-test
+  "principal threaded to handler"
+  (contains?
+    (dream-resp-body (host-mw-protected (host-mw-req "Bearer good")))
+    "\"data\":\"alice\"")
+  true)
+(host-mw-test
+  "authed but not permitted -> 403"
+  (dream-status (host-mw-protected-del (host-mw-req "Bearer good")))
+  403)
+(host-mw-test
+  "403 envelope"
+  (contains?
+    (dream-resp-body (host-mw-protected-del (host-mw-req "Bearer good")))
+    "\"error\":\"forbidden\"")
+  true)
+
+;; ── error trapping ─────────────────────────────────────────────────
+(define host-mw-boom (fn (req) (error "kaboom")))
+(host-mw-test
+  "wrap-errors -> 500"
+  (dream-status ((host/wrap-errors host-mw-boom) (host-mw-req nil)))
+  500)
+(host-mw-test
+  "500 envelope"
+  (contains?
+    (dream-resp-body ((host/wrap-errors host-mw-boom) (host-mw-req nil)))
+    "\"ok\":false")
+  true)
+
+(define
+  host-mw-tests-run!
+  (fn
+    ()
+    {:total (+ host-mw-pass host-mw-fail)
+     :passed host-mw-pass
+     :failed host-mw-fail
+     :fails host-mw-fails}))

lib/host/tests/page.sx

@@ -0,0 +1,60 @@
+;; lib/host/tests/page.sx — the host's interactive-SX-page capability (Phase 5.1).
+;; A defcomp component tree (with keyword attributes + nesting) renders to correct
+;; HTML through host/page / render-page, served by a host route. This is the
+;; capability the legacy editor (and any future island UI) needs — proven on a
+;; small component so it's not editor-specific.
+
+(define host-pg-pass 0)
+(define host-pg-fail 0)
+(define host-pg-fails (list))
+(define
+  host-pg-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! host-pg-pass (+ host-pg-pass 1))
+      (begin
+        (set! host-pg-fail (+ host-pg-fail 1))
+        (append! host-pg-fails {:name name :actual actual :expected expected})))))
+
+;; A component with keyword attributes (the case bare render-to-html mangles) and
+;; a nested component (expansion must recurse).
+(defcomp ~pg-badge (&key (label :as string))
+  (span :class "badge" :data-kind "tag" label))
+(defcomp ~pg-card (&key (title :as string))
+  (div :class "card"
+    (h2 :class "card-title" title)
+    (~pg-badge :label "new")))
+
+(define host-pg-req (fn (target) (dream-request "GET" target {} "")))
+(define host-pg-app
+  (host/make-app (list (list (host/page-route "/card" (quote (~pg-card :title "Hello")))))))
+
+(define host-pg-body (dream-resp-body (host-pg-app (host-pg-req "/card"))))
+
+(host-pg-test "page 200"
+  (dream-status (host-pg-app (host-pg-req "/card"))) 200)
+(host-pg-test "page is html"
+  (contains? (dream-resp-header (host-pg-app (host-pg-req "/card")) "content-type") "text/html")
+  true)
+;; attributes survive (the whole point) — class on the outer div
+(host-pg-test "outer div class attr"
+  (contains? host-pg-body "class=\"card\"") true)
+;; nested component expanded + its attrs survive
+(host-pg-test "nested component expanded"
+  (contains? host-pg-body "class=\"badge\"") true)
+(host-pg-test "nested data attr"
+  (contains? host-pg-body "data-kind=\"tag\"") true)
+;; keyword param values rendered as text content, not attrs
+(host-pg-test "title text rendered"
+  (contains? host-pg-body "Hello") true)
+(host-pg-test "badge label text rendered"
+  (contains? host-pg-body ">new<") true)
+;; NOT mangled — the keyword ":class" must not leak as text content
+(host-pg-test "no mangled keyword text"
+  (contains? host-pg-body ">classcard") false)
+
+(define
+  host-pg-tests-run!
+  (fn ()
+    {:total (+ host-pg-pass host-pg-fail)
+     :passed host-pg-pass :failed host-pg-fail :fails host-pg-fails}))

lib/host/tests/relations.sx

@@ -0,0 +1,180 @@
+;; lib/host/tests/relations.sx — the migrated relations read endpoints,
+;; GET /internal/data/get-children and /get-parents, dispatching to lib/relations.
+;; Golden tests pin each endpoint to "subsystem call + standard envelope": the
+;; host adds the HTTP/JSON shell over relations/children|parents and nothing else
+;; (golden derived from the same subsystem call, so result order matches).
+
+(define host-rl-pass 0)
+(define host-rl-fail 0)
+(define host-rl-fails (list))
+
+(define
+  host-rl-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-rl-pass (+ host-rl-pass 1))
+      (begin
+        (set! host-rl-fail (+ host-rl-fail 1))
+        (append! host-rl-fails {:name name :actual actual :expected expected})))))
+
+(define host-rl-req (fn (target) (dream-request "GET" target {} "")))
+(define host-rl-app (host/make-app (list host/relations-routes)))
+(define host-rl-sym (fn (s) (string->symbol s)))
+
+;; ── seed a known graph ──────────────────────────────────────────────
+;; org:1 --member--> list:7, list:8 ; org:1 --owner--> page:9
+(relations/load! (list))
+(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:7") (host-rl-sym "member"))
+(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:8") (host-rl-sym "member"))
+(relations/relate (host-rl-sym "org:1") (host-rl-sym "page:9") (host-rl-sym "owner"))
+
+;; ── get-children ────────────────────────────────────────────────────
+(define host-rl-kids
+  "/internal/data/get-children?parent-type=org&parent-id=1&relation-type=member")
+(host-rl-test "children 200" (dream-status (host-rl-app (host-rl-req host-rl-kids))) 200)
+(host-rl-test
+  "children has list:7"
+  (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:7")
+  true)
+(host-rl-test
+  "children has list:8"
+  (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:8")
+  true)
+(host-rl-test
+  "children excludes other-kind page:9"
+  (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "page:9")
+  false)
+(host-rl-test
+  "children count via subsystem"
+  (len (relations/children (host-rl-sym "org:1") (host-rl-sym "member")))
+  2)
+
+;; child-type filter narrows by node prefix.
+(host-rl-test
+  "children child-type=list keeps both"
+  (contains?
+    (dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=list"))))
+    "list:8")
+  true)
+(host-rl-test
+  "children child-type=page filters all out"
+  (contains?
+    (dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=page"))))
+    "list:7")
+  false)
+
+;; ── get-parents ─────────────────────────────────────────────────────
+(define host-rl-par
+  "/internal/data/get-parents?child-type=list&child-id=7&relation-type=member")
+(host-rl-test "parents 200" (dream-status (host-rl-app (host-rl-req host-rl-par))) 200)
+(host-rl-test
+  "parents has org:1"
+  (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-par))) "org:1")
+  true)
+
+;; ── missing required params -> 400 ──────────────────────────────────
+(host-rl-test
+  "children missing param -> 400"
+  (dream-status (host-rl-app (host-rl-req "/internal/data/get-children?parent-type=org")))
+  400)
+(host-rl-test
+  "parents missing param -> 400"
+  (dream-status (host-rl-app (host-rl-req "/internal/data/get-parents?child-type=list")))
+  400)
+
+;; ── golden: endpoint = subsystem call + envelope ────────────────────
+(host-rl-test
+  "golden children"
+  (dream-resp-body (host-rl-app (host-rl-req host-rl-kids)))
+  (str
+    "{\"ok\":true,\"data\":"
+    (dream-json-encode
+      (host/-rel-strings (relations/children (host-rl-sym "org:1") (host-rl-sym "member"))))
+    "}"))
+(host-rl-test
+  "golden parents"
+  (dream-resp-body (host-rl-app (host-rl-req host-rl-par)))
+  (str
+    "{\"ok\":true,\"data\":"
+    (dream-json-encode
+      (host/-rel-strings (relations/parents (host-rl-sym "list:7") (host-rl-sym "member"))))
+    "}"))
+
+;; ── writes: attach-child / detach-child (auth + ACL + closed loop) ──
+(acl/load!
+  (list
+    (acl-grant "carol" "relate" "relations")
+    (acl-grant "carol" "unrelate" "relations")))
+;; carol is permitted; dave authenticates but has no grant.
+(define host-rl-resolve
+  (fn (tok)
+    (cond ((= tok "good") "carol") ((= tok "weak") "dave") (true nil))))
+(define host-rl-wapp
+  (host/make-app
+    (list host/relations-routes (host/relations-write-routes host-rl-resolve))))
+(define host-rl-post
+  (fn (action auth body)
+    (dream-request "POST" (str "/internal/actions/" action)
+      (if auth {:authorization auth} {}) body)))
+(define host-rl-edge
+  "{\"parent-type\":\"org\",\"parent-id\":\"2\",\"child-type\":\"list\",\"child-id\":\"5\",\"relation-type\":\"member\"}")
+(define host-rl-org2
+  "/internal/data/get-children?parent-type=org&parent-id=2&relation-type=member")
+
+(relations/load! (list))
+
+;; auth gate
+(host-rl-test
+  "attach no auth -> 401"
+  (dream-status (host-rl-wapp (host-rl-post "attach-child" nil "{}")))
+  401)
+(host-rl-test
+  "attach authed-but-unpermitted -> 403"
+  (dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer weak" host-rl-edge)))
+  403)
+(host-rl-test
+  "graph unchanged after 403"
+  (len (relations/children (host-rl-sym "org:2") (host-rl-sym "member")))
+  0)
+
+;; permitted attach -> 201, and visible through the migrated read
+(host-rl-test
+  "attach authed+permitted -> 201"
+  (dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" host-rl-edge)))
+  201)
+(host-rl-test
+  "attached edge visible via get-children"
+  (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5")
+  true)
+
+;; detach -> 200, and gone from the read
+(host-rl-test
+  "detach authed+permitted -> 200"
+  (dream-status (host-rl-wapp (host-rl-post "detach-child" "Bearer good" host-rl-edge)))
+  200)
+(host-rl-test
+  "detached edge gone from get-children"
+  (contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5")
+  false)
+
+;; bad payloads
+(host-rl-test
+  "attach non-object body -> 400"
+  (dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" "[1,2]")))
+  400)
+(host-rl-test
+  "attach missing param -> 400"
+  (dream-status
+    (host-rl-wapp (host-rl-post "attach-child" "Bearer good" "{\"parent-type\":\"org\"}")))
+  400)
+
+(define
+  host-rl-tests-run!
+  (fn
+    ()
+    {:total (+ host-rl-pass host-rl-fail)
+     :passed host-rl-pass
+     :failed host-rl-fail
+     :fails host-rl-fails}))

lib/host/tests/router.sx

@@ -0,0 +1,75 @@
+;; lib/host/tests/router.sx — host app assembly: health endpoint, group mounting,
+;; 404 fallback.
+
+(define host-rt-pass 0)
+(define host-rt-fail 0)
+(define host-rt-fails (list))
+
+(define
+  host-rt-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-rt-pass (+ host-rt-pass 1))
+      (begin
+        (set! host-rt-fail (+ host-rt-fail 1))
+        (append! host-rt-fails {:name name :actual actual :expected expected})))))
+
+(define
+  host-rt-req
+  (fn (method target) (dream-request method target {} "")))
+
+;; An app built from one domain group of two routes.
+(define
+  host-rt-app
+  (host/make-app
+    (list
+      (list
+        (dream-get "/ping" (fn (req) (host/ok "pong")))
+        (dream-get "/widgets/:id" (fn (req) (host/ok (dream-param req "id"))))))))
+
+;; ── health ─────────────────────────────────────────────────────────
+(host-rt-test
+  "health status 200"
+  (dream-status (host-rt-app (host-rt-req "GET" "/health")))
+  200)
+(host-rt-test
+  "health body healthy"
+  (contains?
+    (dream-resp-body (host-rt-app (host-rt-req "GET" "/health")))
+    "healthy")
+  true)
+
+;; ── group routes mounted ───────────────────────────────────────────
+(host-rt-test
+  "group route ping"
+  (contains?
+    (dream-resp-body (host-rt-app (host-rt-req "GET" "/ping")))
+    "pong")
+  true)
+(host-rt-test
+  "group path param"
+  (contains?
+    (dream-resp-body (host-rt-app (host-rt-req "GET" "/widgets/42")))
+    "\"data\":\"42\"")
+  true)
+
+;; ── fallback ───────────────────────────────────────────────────────
+(host-rt-test
+  "unknown path 404"
+  (dream-status (host-rt-app (host-rt-req "GET" "/nope")))
+  404)
+(host-rt-test
+  "wrong method 405"
+  (dream-status (host-rt-app (host-rt-req "POST" "/ping")))
+  405)
+
+(define
+  host-rt-tests-run!
+  (fn
+    ()
+    {:total (+ host-rt-pass host-rt-fail)
+     :passed host-rt-pass
+     :failed host-rt-fail
+     :fails host-rt-fails}))

lib/host/tests/server.sx

@@ -0,0 +1,88 @@
+;; lib/host/tests/server.sx — the native<->dream bridge. Pure-function coverage of
+;; host/-native->dream, host/-dream->native, and the host/native-handler adapter
+;; over a real host app (no socket — the http-listen call itself is exercised live
+;; via lib/host/serve.sx, not here).
+
+(define host-sv-pass 0)
+(define host-sv-fail 0)
+(define host-sv-fails (list))
+
+(define
+  host-sv-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-sv-pass (+ host-sv-pass 1))
+      (begin
+        (set! host-sv-fail (+ host-sv-fail 1))
+        (append! host-sv-fails {:name name :actual actual :expected expected})))))
+
+(define host-sv-native
+  (fn (method path query body)
+    {"method" method "path" path "query" query "body" body "headers" {}}))
+
+;; ── native request -> dream request ─────────────────────────────────
+(define host-sv-dreq (host/-native->dream (host-sv-native "post" "/feed" "actor=alice" "hi")))
+(host-sv-test "n->d method upcased" (get host-sv-dreq :method) "POST")
+(host-sv-test "n->d path" (get host-sv-dreq :path) "/feed")
+(host-sv-test "n->d query param" (dream-query-param host-sv-dreq "actor") "alice")
+(host-sv-test "n->d body" (get host-sv-dreq :body) "hi")
+;; empty query -> bare path, no trailing "?"
+(host-sv-test
+  "n->d empty query -> bare path"
+  (get (host/-native->dream (host-sv-native "GET" "/health" "" "")) :path)
+  "/health")
+
+;; ── dream response -> native response ───────────────────────────────
+(define host-sv-nresp
+  (host/-dream->native (dream-response 201 {:content-type "application/json"} "{}")))
+(host-sv-test "d->n status" (get host-sv-nresp :status) 201)
+(host-sv-test "d->n body" (get host-sv-nresp :body) "{}")
+(host-sv-test "d->n headers is dict" (= (type-of (get host-sv-nresp :headers)) "dict") true)
+
+;; ── adapter over a real host app ────────────────────────────────────
+(feed/reset!)
+(define host-sv-app (host/native-handler (host/make-app (list host/feed-routes))))
+(host-sv-test
+  "health -> 200"
+  (get (host-sv-app (host-sv-native "GET" "/health" "" "")) :status)
+  200)
+(host-sv-test
+  "health body healthy"
+  (contains? (get (host-sv-app (host-sv-native "GET" "/health" "" "")) :body) "healthy")
+  true)
+(host-sv-test
+  "feed read -> 200"
+  (get (host-sv-app (host-sv-native "GET" "/feed" "" "")) :status)
+  200)
+;; native response shape is exactly {:status :headers :body}
+(host-sv-test
+  "native resp keys"
+  (let ((r (host-sv-app (host-sv-native "GET" "/health" "" ""))))
+    (and (has-key? r :status) (has-key? r :headers) (has-key? r :body)))
+  true)
+
+;; ── relations read through the bridge (end-to-end shape) ────────────
+(relations/load! (list))
+(relations/relate (string->symbol "org:1") (string->symbol "list:7") (string->symbol "member"))
+(define host-sv-rapp (host/native-handler (host/make-app (list host/relations-routes))))
+(host-sv-test
+  "relations read via bridge"
+  (contains?
+    (get
+      (host-sv-rapp
+        (host-sv-native "GET" "/internal/data/get-children"
+          "parent-type=org&parent-id=1&relation-type=member" ""))
+      :body)
+    "list:7")
+  true)
+
+(define
+  host-sv-tests-run!
+  (fn
+    ()
+    {:total (+ host-sv-pass host-sv-fail)
+     :passed host-sv-pass
+     :failed host-sv-fail
+     :fails host-sv-fails}))

lib/host/tests/sxtp.sx

@@ -0,0 +1,129 @@
+;; lib/host/tests/sxtp.sx — SXTP message algebra, wire serialise/parse round-trip,
+;; and the Dream HTTP <-> SXTP bridge.
+
+(define host-sx-pass 0)
+(define host-sx-fail 0)
+(define host-sx-fails (list))
+
+(define
+  host-sx-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! host-sx-pass (+ host-sx-pass 1))
+      (begin
+        (set! host-sx-fail (+ host-sx-fail 1))
+        (append! host-sx-fails {:name name :actual actual :expected expected})))))
+
+;; ── constructors + predicates ──────────────────────────────────────
+(define host-sx-req (sxtp/request "navigate" "/x" {:headers {:host "h"}}))
+(define host-sx-resp (sxtp/ok {:id "e1"}))
+
+(host-sx-test "request?" (sxtp/request? host-sx-req) true)
+(host-sx-test "request not response" (sxtp/response? host-sx-req) false)
+(host-sx-test "response?" (sxtp/response? host-sx-resp) true)
+(host-sx-test "condition?" (sxtp/condition? (sxtp/condition "x" {})) true)
+
+;; ── accessors (verb/status are symbols) ────────────────────────────
+(host-sx-test "verb" (symbol->string (sxtp/verb host-sx-req)) "navigate")
+(host-sx-test "path" (sxtp/path host-sx-req) "/x")
+(host-sx-test "req header" (get (sxtp/req-headers host-sx-req) :host) "h")
+(host-sx-test "status" (symbol->string (sxtp/status host-sx-resp)) "ok")
+(host-sx-test "body" (get (sxtp/body host-sx-resp) :id) "e1")
+
+;; ── status helpers ─────────────────────────────────────────────────
+(host-sx-test "created status" (symbol->string (sxtp/status (sxtp/created {}))) "created")
+(host-sx-test
+  "not-found status"
+  (symbol->string (sxtp/status (sxtp/not-found "/p" "gone")))
+  "not-found")
+(host-sx-test
+  "not-found body is condition"
+  (sxtp/condition? (sxtp/body (sxtp/not-found "/p" "gone")))
+  true)
+(host-sx-test
+  "forbidden message"
+  (sxtp/cond-message (sxtp/body (sxtp/forbidden "no")))
+  "no")
+
+;; ── serialise (deterministic top-level field order) ────────────────
+(host-sx-test
+  "serialize request"
+  (sxtp/serialize host-sx-req)
+  "(request :verb navigate :path \"/x\" :headers {:host \"h\"})")
+(host-sx-test
+  "serialize ok"
+  (sxtp/serialize (sxtp/ok {:id "e1"}))
+  "(response :status ok :body {:id \"e1\"})")
+;; nested condition rides the wire in its (condition ...) list form, no :msg leak.
+(host-sx-test
+  "serialize nested condition as list"
+  (contains?
+    (sxtp/serialize (sxtp/not-found "/p" "gone"))
+    "(condition :type resource-not-found")
+  true)
+(host-sx-test
+  "serialize no :msg leak"
+  (contains? (sxtp/serialize host-sx-resp) ":msg")
+  false)
+
+;; ── parse + round-trip ─────────────────────────────────────────────
+(define host-sx-parsed
+  (sxtp/parse "(request :verb query :path \"/events\" :headers {:host \"h\"})"))
+(host-sx-test "parse msg type" (sxtp/request? host-sx-parsed) true)
+(host-sx-test "parse verb" (symbol->string (sxtp/verb host-sx-parsed)) "query")
+(host-sx-test "parse path" (sxtp/path host-sx-parsed) "/events")
+(host-sx-test
+  "parse nested header normalised"
+  (get (sxtp/req-headers host-sx-parsed) :host)
+  "h")
+
+(define host-sx-rt (sxtp/parse (sxtp/serialize (sxtp/ok {:id "e1" :n 3}))))
+(host-sx-test "round-trip status" (symbol->string (sxtp/status host-sx-rt)) "ok")
+(host-sx-test "round-trip body id" (get (sxtp/body host-sx-rt) :id) "e1")
+(host-sx-test "round-trip body n" (get (sxtp/body host-sx-rt) :n) 3)
+
+;; ── HTTP <-> SXTP mappings ─────────────────────────────────────────
+(host-sx-test "verb GET->fetch" (symbol->string (sxtp/verb-for-method "GET")) "fetch")
+(host-sx-test "verb POST->create" (symbol->string (sxtp/verb-for-method "POST")) "create")
+(host-sx-test "verb DELETE->delete" (symbol->string (sxtp/verb-for-method "DELETE")) "delete")
+(host-sx-test "verb unknown->fetch" (symbol->string (sxtp/verb-for-method "WIBBLE")) "fetch")
+(host-sx-test "http ok->200" (sxtp/http-status (string->symbol "ok")) 200)
+(host-sx-test "http not-found->404" (sxtp/http-status (string->symbol "not-found")) 404)
+
+;; ── Dream bridge ───────────────────────────────────────────────────
+(define host-sx-from
+  (sxtp/from-dream (dream-request "POST" "/feed?a=1" {} "hi")))
+(host-sx-test "from-dream verb" (symbol->string (sxtp/verb host-sx-from)) "create")
+(host-sx-test "from-dream path" (sxtp/path host-sx-from) "/feed")
+(host-sx-test "from-dream param" (sxtp/param host-sx-from "a") "1")
+(host-sx-test "from-dream body" (sxtp/body host-sx-from) "hi")
+
+(define host-sx-tod (sxtp/to-dream (sxtp/ok {:id "e1"})))
+(host-sx-test "to-dream status" (dream-status host-sx-tod) 200)
+(host-sx-test
+  "to-dream content-type text/sx"
+  (dream-resp-header host-sx-tod "content-type")
+  "text/sx")
+(host-sx-test
+  "to-dream body is sx text"
+  (dream-resp-body host-sx-tod)
+  "{:id \"e1\"}")
+(host-sx-test
+  "to-dream not-found->404"
+  (dream-status (sxtp/to-dream (sxtp/not-found "/p" "gone")))
+  404)
+(host-sx-test
+  "to-dream forbidden->403"
+  (dream-status (sxtp/to-dream (sxtp/forbidden "no")))
+  403)
+
+(define
+  host-sx-tests-run!
+  (fn
+    ()
+    {:total (+ host-sx-pass host-sx-fail)
+     :passed host-sx-pass
+     :failed host-sx-fail
+     :fails host-sx-fails}))

lib/maude/conditional.sx

@@ -1,164 +0,0 @@
-;; lib/maude/conditional.sx — conditional equations (Phase 4) + owise.
-;;
-;; A condition-aware superset of the Phase 3 reducer. `ceq L = R if COND` fires
-;; only when COND holds under the matching substitution. Conditions come from
-;; the parser as:
-;;   {:kind :eq :lhs L :rhs R}   — holds iff reduce(s L) =AC= reduce(s R)
-;;   {:kind :bool :term T}       — holds iff reduce(s T) =AC= true
-;; Condition evaluation recurses through the SAME reducer (mau/cnormalize), so
-;; a ceq whose guard mentions other (possibly conditional) equations Just Works
-;; — termination rests on the guard reducing on structurally smaller arguments
-;; (and the global fuel guard).
-;;
-;; `owise` (otherwise): an equation tagged [owise] fires at a redex only when
-;; NO ordinary equation applies there. crewrite-top is two-pass: ordinary
-;; equations first, owise equations last.
-;;
-;; Single-step firing uses the short-circuiting matcher in fire.sx
-;; (mau/fire-eq). The eager candidate enumeration (mau/eq-candidates) is
-;; retained for `search` (rewrite.sx), which genuinely needs every successor.
-
-(define
-  mau/ac-candidates
-  (fn
-    (theory f th eq term)
-    (let
-      ((id (get th :id))
-        (pels (mau/flatten-op theory f (get eq :lhs)))
-        (sels (mau/flatten-op theory f term)))
-      (let
-        ((matches (if (get th :comm) (mau/match-multiset theory f (mau/append2 pels (list (mau/var "$R" ""))) sels {} id) (mau/match-sequence theory f (mau/append2 (list (mau/var "$L" "")) (mau/append2 pels (list (mau/var "$R" "")))) sels {} id))))
-        (map (fn (s) {:s s :result (mau/ac-eq-result theory f th eq s)}) matches)))))
-
-(define
-  mau/eq-candidates
-  (fn
-    (theory eq term)
-    (let
-      ((lhs (get eq :lhs)))
-      (let
-        ((th (if (mau/app? lhs) (mau/th-of theory (mau/op lhs)) {:id nil :assoc false :comm false})))
-        (if
-          (and (mau/app? lhs) (get th :assoc))
-          (mau/ac-candidates theory (mau/op lhs) th eq term)
-          (map (fn (s) {:s s :result (mau/subst-apply s (get eq :rhs))}) (mau/mm theory lhs term {})))))))
-
-(define
-  mau/cond-holds?
-  (fn
-    (theory eqs cond s)
-    (if
-      (= cond nil)
-      true
-      (if
-        (= (get cond :kind) "eq")
-        (mau/ac-equal?
-          theory
-          (mau/cnormalize
-            theory
-            eqs
-            (mau/subst-apply s (get cond :lhs))
-            mau/reduce-fuel)
-          (mau/cnormalize
-            theory
-            eqs
-            (mau/subst-apply s (get cond :rhs))
-            mau/reduce-fuel))
-        (mau/ac-equal?
-          theory
-          (mau/cnormalize
-            theory
-            eqs
-            (mau/subst-apply s (get cond :term))
-            mau/reduce-fuel)
-          (mau/const "true"))))))
-
-(define
-  mau/try-candidates
-  (fn
-    (theory all-eqs cond term cands)
-    (if
-      (empty? cands)
-      nil
-      (let
-        ((c (first cands)))
-        (if
-          (and
-            (not (mau/ac-equal? theory (get c :result) term))
-            (mau/cond-holds? theory all-eqs cond (get c :s)))
-          (get c :result)
-          (mau/try-candidates theory all-eqs cond term (rest cands)))))))
-
-;; ---- owise partitioning ----
-
-(define mau/eq-owise? (fn (e) (= (get e :owise) true)))
-(define mau/filter-owise (fn (eqs) (filter mau/eq-owise? eqs)))
-(define
-  mau/filter-noowise
-  (fn (eqs) (filter (fn (e) (not (mau/eq-owise? e))) eqs)))
-
-(define
-  mau/crewrite-loop
-  (fn
-    (theory all-eqs eqs term)
-    (if
-      (empty? eqs)
-      nil
-      (let
-        ((r (mau/fire-eq theory all-eqs (first eqs) term)))
-        (if (= r nil) (mau/crewrite-loop theory all-eqs (rest eqs) term) r)))))
-
-(define
-  mau/crewrite-top
-  (fn
-    (theory eqs term)
-    (let
-      ((r (mau/crewrite-loop theory eqs (mau/filter-noowise eqs) term)))
-      (if
-        (= r nil)
-        (mau/crewrite-loop theory eqs (mau/filter-owise eqs) term)
-        r))))
-
-(define
-  mau/cnormalize
-  (fn
-    (theory eqs term fuel)
-    (if
-      (<= fuel 0)
-      term
-      (cond
-        ((mau/var? term) term)
-        ((mau/app? term)
-          (let
-            ((nargs (map (fn (a) (mau/cnormalize theory eqs a fuel)) (mau/args term))))
-            (let
-              ((t2 (mau/app (mau/op term) nargs)))
-              (let
-                ((r (mau/crewrite-top theory eqs t2)))
-                (if
-                  (= r nil)
-                  t2
-                  (mau/cnormalize theory eqs r (- fuel 1)))))))
-        (else term)))))
-
-(define
-  mau/creduce
-  (fn
-    (m term)
-    (mau/cnormalize
-      (mau/build-theory m)
-      (mau/module-eqs m)
-      term
-      mau/reduce-fuel)))
-
-(define
-  mau/creduce-term
-  (fn (m src) (mau/creduce m (mau/parse-term-in m src))))
-
-(define
-  mau/creduce->str
-  (fn (m src) (mau/term->str (mau/creduce-term m src))))
-
-(define
-  mau/ccanon
-  (fn (m src) (mau/canon (mau/build-theory m) (mau/creduce-term m src))))

lib/maude/confluence.sx

@@ -1,268 +0,0 @@
-;; lib/maude/confluence.sx — critical-pair / local-confluence checking.
-;;
-;; A terminating equation set is confluent iff every critical pair is joinable
-;; (Knuth-Bendix / Newman). A critical pair arises when two oriented equations
-;; overlap: a non-variable subterm of one LHS unifies with the other LHS, giving
-;; two ways to rewrite the overlap; they must reduce to the same normal form.
-;;
-;; This needs TWO-SIDED unification (variables on both sides), not the one-sided
-;; matching the reducer uses — so this file carries its own syntactic unifier.
-;;
-;; SCOPE / honesty: the unifier is SYNTACTIC. For free/constructor operators the
-;; check is exact. For assoc/comm (AC) operators it sees only syntactic overlaps
-;; (full AC-unification is NP/infinitary — out of scope), but joinability is
-;; tested with `mau/ac-equal?` (canonical form modulo the theory), so AC laws are
-;; joined correctly even though their overlaps are under-approximated. Conditional
-;; and `owise` equations are not oriented (skipped).
-
-;; ---------- syntactic unification (vars on both sides) ----------
-
-(define
-  mau/u-walk
-  (fn
-    (t s)
-    (if
-      (mau/var? t)
-      (let
-        ((b (get s (mau/vname t))))
-        (if (= b nil) t (mau/u-walk b s)))
-      t)))
-
-(define
-  mau/u-occurs?
-  (fn
-    (name t s)
-    (let
-      ((w (mau/u-walk t s)))
-      (cond
-        ((mau/var? w) (= (mau/vname w) name))
-        ((mau/app? w) (mau/u-occurs-any? name (mau/args w) s))
-        (else false)))))
-
-(define
-  mau/u-occurs-any?
-  (fn
-    (name args s)
-    (cond
-      ((empty? args) false)
-      ((mau/u-occurs? name (first args) s) true)
-      (else (mau/u-occurs-any? name (rest args) s)))))
-
-(define
-  mau/u-unify-args
-  (fn
-    (as bs s)
-    (cond
-      ((= s nil) nil)
-      ((and (empty? as) (empty? bs)) s)
-      ((or (empty? as) (empty? bs)) nil)
-      (else
-        (mau/u-unify-args
-          (rest as)
-          (rest bs)
-          (mau/u-unify (first as) (first bs) s))))))
-
-(define
-  mau/u-unify
-  (fn
-    (t1 t2 s)
-    (if
-      (= s nil)
-      nil
-      (let
-        ((a (mau/u-walk t1 s)) (b (mau/u-walk t2 s)))
-        (cond
-          ((and (mau/var? a) (mau/var? b) (= (mau/vname a) (mau/vname b)))
-            s)
-          ((mau/var? a)
-            (if
-              (mau/u-occurs? (mau/vname a) b s)
-              nil
-              (assoc s (mau/vname a) b)))
-          ((mau/var? b)
-            (if
-              (mau/u-occurs? (mau/vname b) a s)
-              nil
-              (assoc s (mau/vname b) a)))
-          ((and (mau/app? a) (mau/app? b))
-            (if
-              (and
-                (= (mau/op a) (mau/op b))
-                (= (mau/arity a) (mau/arity b)))
-              (mau/u-unify-args (mau/args a) (mau/args b) s)
-              nil))
-          (else nil))))))
-
-(define
-  mau/u-apply
-  (fn
-    (t s)
-    (let
-      ((w (mau/u-walk t s)))
-      (if
-        (mau/app? w)
-        (mau/app
-          (mau/op w)
-          (map (fn (a) (mau/u-apply a s)) (mau/args w)))
-        w))))
-
-(define
-  mau/u-rename
-  (fn
-    (t suffix)
-    (cond
-      ((mau/var? t) (mau/var (str (mau/vname t) suffix) (mau/vsort t)))
-      ((mau/app? t)
-        (mau/app
-          (mau/op t)
-          (map (fn (a) (mau/u-rename a suffix)) (mau/args t))))
-      (else t))))
-
-;; ---------- positions ----------
-
-(define
-  mau/positions-args
-  (fn
-    (args i)
-    (if
-      (empty? args)
-      (list)
-      (mau/append2
-        (map (fn (p) (cons i p)) (mau/nv-positions (first args)))
-        (mau/positions-args (rest args) (+ i 1))))))
-
-;; non-variable positions (paths) of a term; root = empty path
-(define
-  mau/nv-positions
-  (fn
-    (t)
-    (if
-      (mau/app? t)
-      (cons (list) (mau/positions-args (mau/args t) 0))
-      (list))))
-
-(define
-  mau/at-path
-  (fn
-    (t path)
-    (if
-      (empty? path)
-      t
-      (mau/at-path (nth (mau/args t) (first path)) (rest path)))))
-
-(define
-  mau/replace-nth
-  (fn
-    (xs i v)
-    (if
-      (= i 0)
-      (cons v (rest xs))
-      (cons (first xs) (mau/replace-nth (rest xs) (- i 1) v)))))
-
-(define
-  mau/replace-at
-  (fn
-    (t path new)
-    (if
-      (empty? path)
-      new
-      (mau/app
-        (mau/op t)
-        (mau/replace-nth
-          (mau/args t)
-          (first path)
-          (mau/replace-at (nth (mau/args t) (first path)) (rest path) new))))))
-
-;; ---------- critical pairs ----------
-
-(define
-  mau/eq-same?
-  (fn
-    (e1 e2)
-    (and
-      (mau/term=? (get e1 :lhs) (get e2 :lhs))
-      (mau/term=? (get e1 :rhs) (get e2 :rhs)))))
-
-(define
-  mau/cps-at
-  (fn
-    (l1 r1 l2 r2 same? paths)
-    (if
-      (empty? paths)
-      (list)
-      (let
-        ((p (first paths)))
-        (if
-          (and same? (empty? p))
-          (mau/cps-at l1 r1 l2 r2 same? (rest paths))
-          (let
-            ((s (mau/u-unify (mau/at-path l1 p) l2 {})))
-            (if
-              (= s nil)
-              (mau/cps-at l1 r1 l2 r2 same? (rest paths))
-              (cons {:right (mau/u-apply (mau/replace-at l1 p r2) s) :left (mau/u-apply r1 s)} (mau/cps-at l1 r1 l2 r2 same? (rest paths))))))))))
-
-(define
-  mau/cps-of
-  (fn
-    (e1 e2)
-    (let
-      ((l1 (mau/u-rename (get e1 :lhs) "#1"))
-        (r1 (mau/u-rename (get e1 :rhs) "#1"))
-        (l2 (mau/u-rename (get e2 :lhs) "#2"))
-        (r2 (mau/u-rename (get e2 :rhs) "#2")))
-      (mau/cps-at l1 r1 l2 r2 (mau/eq-same? e1 e2) (mau/nv-positions l1)))))
-
-(define
-  mau/all-cps
-  (fn
-    (eqs)
-    (mau/concat-map
-      (fn (e1) (mau/concat-map (fn (e2) (mau/cps-of e1 e2)) eqs))
-      eqs)))
-
-;; ---------- public API ----------
-
-(define
-  mau/orientable-eqs
-  (fn
-    (m)
-    (filter
-      (fn (e) (and (= (get e :cond) nil) (not (= (get e :owise) true))))
-      (mau/module-eqs m))))
-
-(define
-  mau/joinable?
-  (fn
-    (theory eqs t1 t2)
-    (mau/ac-equal?
-      theory
-      (mau/cnormalize theory eqs t1 mau/reduce-fuel)
-      (mau/cnormalize theory eqs t2 mau/reduce-fuel))))
-
-(define mau/critical-pairs (fn (m) (mau/all-cps (mau/orientable-eqs m))))
-
-(define
-  mau/non-joinable-pairs
-  (fn
-    (m)
-    (let
-      ((theory (mau/build-theory m)) (eqs (mau/module-eqs m)))
-      (filter
-        (fn
-          (cp)
-          (not (mau/joinable? theory eqs (get cp :left) (get cp :right))))
-        (mau/all-cps (mau/orientable-eqs m))))))
-
-(define mau/confluent? (fn (m) (empty? (mau/non-joinable-pairs m))))
-
-(define
-  mau/cp->str
-  (fn
-    (m cp)
-    (let
-      ((theory (mau/build-theory m)))
-      (str
-        (mau/canon theory (get cp :left))
-        " <?> "
-        (mau/canon theory (get cp :right))))))

lib/maude/conformance.conf

@@ -1,41 +0,0 @@
-# Maude conformance config — sourced by lib/guest/conformance.sh.
-
-LANG_NAME=maude
-MODE=dict
-
-PRELOADS=(
-  lib/guest/lex.sx
-  lib/guest/pratt.sx
-  lib/maude/term.sx
-  lib/maude/parser.sx
-  lib/maude/sorts.sx
-  lib/maude/reduce.sx
-  lib/maude/matching.sx
-  lib/maude/conditional.sx
-  lib/maude/fire.sx
-  lib/maude/confluence.sx
-  lib/maude/rewrite.sx
-  lib/maude/searchpath.sx
-  lib/maude/strategy.sx
-  lib/maude/meta.sx
-  lib/maude/pretty.sx
-  lib/maude/run.sx
-)
-
-SUITES=(
-  "parse:lib/maude/tests/parse.sx:(mau-parse-tests-run!)"
-  "reduce:lib/maude/tests/reduce.sx:(mau-reduce-tests-run!)"
-  "matching:lib/maude/tests/matching.sx:(mau-matching-tests-run!)"
-  "confluence:lib/maude/tests/confluence.sx:(mau-confluence-tests-run!)"
-  "conditional:lib/maude/tests/conditional.sx:(mau-conditional-tests-run!)"
-  "owise:lib/maude/tests/owise.sx:(mau-owise-tests-run!)"
-  "gather:lib/maude/tests/gather.sx:(mau-gather-tests-run!)"
-  "sorts:lib/maude/tests/sorts.sx:(mau-sorts-tests-run!)"
-  "rewrite:lib/maude/tests/rewrite.sx:(mau-rewrite-tests-run!)"
-  "searchpath:lib/maude/tests/searchpath.sx:(mau-searchpath-tests-run!)"
-  "strategy:lib/maude/tests/strategy.sx:(mau-strategy-tests-run!)"
-  "meta:lib/maude/tests/meta.sx:(mau-meta-tests-run!)"
-  "pretty:lib/maude/tests/pretty.sx:(mau-pretty-tests-run!)"
-  "run:lib/maude/tests/run.sx:(mau-run-tests-run!)"
-  "effects:lib/maude/tests/effects.sx:(mau-effects-tests-run!)"
-)

lib/maude/conformance.sh

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

lib/maude/fire.sx

@@ -1,250 +0,0 @@
-;; lib/maude/fire.sx — short-circuiting rule/equation firing.
-;;
-;; The eager matcher (mau/match-multiset) enumerates EVERY substitution, which
-;; is what `mau/match-all` and `search` need. But for a single rewrite step we
-;; only need the FIRST usable match — and eager enumeration is exponential when
-;; an AC argument has many identical elements (q ; q ; ... ; q). These
-;; find-matchers thread a predicate and stop at the first complete match for
-;; which it returns non-nil; the predicate builds the rewritten term and checks
-;; "progresses AND condition holds", so firing short-circuits on the first
-;; productive match instead of materialising the whole solution set.
-;;
-;; pred : subst -> result-term-or-nil   (result is always a term, never nil)
-
-(define
-  mau/try-list
-  (fn
-    (substs cont)
-    (if
-      (empty? substs)
-      nil
-      (let
-        ((r (cont (first substs))))
-        (if (= r nil) (mau/try-list (rest substs) cont) r)))))
-
-;; ---- multiset (assoc+comm) find ----
-
-(define
-  mau/ms-find
-  (fn
-    (theory f pels sels s id pred)
-    (cond
-      ((empty? pels) (if (empty? sels) (pred s) nil))
-      (else
-        (let
-          ((p (first pels)) (prest (rest pels)))
-          (if
-            (mau/var? p)
-            (mau/ms-find-var
-              theory
-              f
-              prest
-              sels
-              s
-              (mau/vname p)
-              id
-              pred
-              (mau/var-kmin (mau/vname p) id)
-              (mau/all-splits sels))
-            (mau/ms-find-nonvar theory f p prest sels s id pred 0)))))))
-
-(define
-  mau/ms-find-nonvar
-  (fn
-    (theory f p prest sels s id pred i)
-    (if
-      (>= i (len sels))
-      nil
-      (let
-        ((others (mau/remove-at sels i)))
-        (let
-          ((r (mau/try-list (mau/mm theory p (nth sels i) s) (fn (s2) (mau/ms-find theory f prest others s2 id pred)))))
-          (if
-            (not (= r nil))
-            r
-            (mau/ms-find-nonvar
-              theory
-              f
-              p
-              prest
-              sels
-              s
-              id
-              pred
-              (+ i 1))))))))
-
-(define
-  mau/ms-find-var
-  (fn
-    (theory f prest sels s name id pred kmin splits)
-    (if
-      (empty? splits)
-      nil
-      (let
-        ((chosen (first (first splits)))
-          (rests (nth (first splits) 1)))
-        (if
-          (< (len chosen) kmin)
-          (mau/ms-find-var
-            theory
-            f
-            prest
-            sels
-            s
-            name
-            id
-            pred
-            kmin
-            (rest splits))
-          (let
-            ((s2 (mau/bind-check theory s name (mau/rebuild f chosen id))))
-            (let
-              ((r (if (= s2 nil) nil (mau/ms-find theory f prest rests s2 id pred))))
-              (if
-                (not (= r nil))
-                r
-                (mau/ms-find-var
-                  theory
-                  f
-                  prest
-                  sels
-                  s
-                  name
-                  id
-                  pred
-                  kmin
-                  (rest splits))))))))))
-
-;; ---- sequence (assoc, ordered) find ----
-
-(define
-  mau/seq-find
-  (fn
-    (theory f pels sels s id pred)
-    (cond
-      ((empty? pels) (if (empty? sels) (pred s) nil))
-      (else
-        (let
-          ((p (first pels)) (prest (rest pels)))
-          (if
-            (mau/var? p)
-            (mau/seq-find-var
-              theory
-              f
-              prest
-              sels
-              s
-              (mau/vname p)
-              id
-              pred
-              (mau/var-kmin (mau/vname p) id))
-            (if
-              (empty? sels)
-              nil
-              (mau/try-list
-                (mau/mm theory p (first sels) s)
-                (fn
-                  (s2)
-                  (mau/seq-find theory f prest (rest sels) s2 id pred))))))))))
-
-(define
-  mau/seq-find-var
-  (fn
-    (theory f prest sels s name id pred k)
-    (if
-      (> k (len sels))
-      nil
-      (let
-        ((s2 (mau/bind-check theory s name (mau/rebuild f (mau/take sels k) id))))
-        (let
-          ((r (if (= s2 nil) nil (mau/seq-find theory f prest (mau/drop sels k) s2 id pred))))
-          (if
-            (not (= r nil))
-            r
-            (mau/seq-find-var
-              theory
-              f
-              prest
-              sels
-              s
-              name
-              id
-              pred
-              (+ k 1))))))))
-
-;; ---- firing an equation/rule (returns rewritten term or nil) ----
-
-(define
-  mau/fire-plain
-  (fn
-    (theory eqs eq term cnd substs)
-    (if
-      (empty? substs)
-      nil
-      (let
-        ((res (mau/subst-apply (first substs) (get eq :rhs))))
-        (if
-          (and
-            (not (mau/ac-equal? theory res term))
-            (mau/cond-holds? theory eqs cnd (first substs)))
-          res
-          (mau/fire-plain theory eqs eq term cnd (rest substs)))))))
-
-(define
-  mau/fire-ac
-  (fn
-    (theory eqs f th eq term cnd)
-    (let
-      ((id (get th :id))
-        (pels (mau/flatten-op theory f (get eq :lhs)))
-        (sels (mau/flatten-op theory f term)))
-      (let
-        ((pred (fn (s) (let ((res (mau/ac-eq-result theory f th eq s))) (if (and (not (mau/ac-equal? theory res term)) (mau/cond-holds? theory eqs cnd s)) res nil)))))
-        (if
-          (get th :comm)
-          (mau/ms-find
-            theory
-            f
-            (mau/append2 pels (list (mau/var "$R" "")))
-            sels
-            {}
-            id
-            pred)
-          (mau/seq-find
-            theory
-            f
-            (mau/append2
-              (list (mau/var "$L" ""))
-              (mau/append2 pels (list (mau/var "$R" ""))))
-            sels
-            {}
-            id
-            pred))))))
-
-(define
-  mau/fire-eq
-  (fn
-    (theory eqs eq term)
-    (let
-      ((lhs (get eq :lhs)) (cnd (get eq :cond)))
-      (if
-        (mau/app? lhs)
-        (let
-          ((th (mau/th-of theory (mau/op lhs))))
-          (if
-            (get th :assoc)
-            (mau/fire-ac theory eqs (mau/op lhs) th eq term cnd)
-            (mau/fire-plain
-              theory
-              eqs
-              eq
-              term
-              cnd
-              (mau/mm theory lhs term {}))))
-        (mau/fire-plain
-          theory
-          eqs
-          eq
-          term
-          cnd
-          (mau/mm theory lhs term {}))))))

lib/maude/matching.sx

@@ -1,565 +0,0 @@
-;; lib/maude/matching.sx — equational matching modulo assoc/comm/id (Phase 3).
-;;
-;; The chisel. Syntactic matching (reduce.sx) returns at most one substitution;
-;; matching modulo a theory is MULTI-VALUED — `X + Y` against `a + b + c` (with
-;; _+_ assoc comm) has several solutions. `mau/mm` returns the full list of
-;; substitutions; callers (rule application) pick.
-;;
-;; Operator theories come from the signature attributes, collected into a dict
-;; OP-NAME -> {:assoc B :comm B :id ELT}. Matching dispatches on the head op's
-;; theory:
-;;   free        positional, exact arity
-;;   comm        binary, try both argument orderings
-;;   assoc       flatten the f-spine, match the pattern sequence against the
-;;               subject sequence (variables grab contiguous blocks)
-;;   assoc+comm  flatten, match as multisets (variables grab sub-multisets)
-;; Identity (id: e) lets a variable grab the empty block, contributing e.
-;;
-;; Equational rewriting (mau/ac-reduce) extends each f-AC equation l=r to
-;; f(REST..., l) -> f(REST..., r) so a rule fires on any sub-multiset of an
-;; AC term, then renormalises to a fixpoint. A candidate rewrite is taken only
-;; if it changes the AC-canonical form (mau/canon) — idempotency/identity
-;; matches that would re-fire forever are skipped, guaranteeing progress.
-
-;; ---------- theory table ----------
-
-(define
-  mau/build-theory
-  (fn
-    (m)
-    (let
-      ((th {}))
-      (for-each
-        (fn
-          (op)
-          (let
-            ((a (get op :attrs)))
-            (dict-set! th (get op :name) {:id (get a :id) :assoc (= (get a :assoc) true) :comm (= (get a :comm) true)})))
-        (mau/module-ops m))
-      th)))
-
-(define
-  mau/th-of
-  (fn
-    (theory op)
-    (let ((e (get theory op))) (if (= e nil) {:id nil :assoc false :comm false} e))))
-
-;; ---------- small list utilities ----------
-
-(define
-  mau/concat-map
-  (fn
-    (f xs)
-    (if
-      (empty? xs)
-      (list)
-      (mau/append2 (f (first xs)) (mau/concat-map f (rest xs))))))
-
-(define
-  mau/remove-at
-  (fn (xs i) (mau/append2 (mau/take xs i) (mau/drop xs (+ i 1)))))
-
-;; All (chosen complement) pairs over every subset of xs.
-(define
-  mau/all-splits
-  (fn
-    (xs)
-    (if
-      (empty? xs)
-      (list (list (list) (list)))
-      (let
-        ((subsplits (mau/all-splits (rest xs))) (x (first xs)))
-        (mau/concat-map
-          (fn
-            (pair)
-            (let
-              ((c (first pair)) (r (nth pair 1)))
-              (list (list (cons x c) r) (list c (cons x r)))))
-          subsplits)))))
-
-;; ---------- flattening of associative spines ----------
-
-(define
-  mau/flatten-op
-  (fn
-    (theory f term)
-    (if
-      (and (mau/app? term) (= (mau/op term) f))
-      (mau/flatten-op-list theory f (mau/args term))
-      (list term))))
-
-(define
-  mau/flatten-op-list
-  (fn
-    (theory f args)
-    (if
-      (empty? args)
-      (list)
-      (mau/append2
-        (mau/flatten-op theory f (first args))
-        (mau/flatten-op-list theory f (rest args))))))
-
-(define
-  mau/foldr-app
-  (fn
-    (f block)
-    (if
-      (empty? (rest block))
-      (first block)
-      (mau/app f (list (first block) (mau/foldr-app f (rest block)))))))
-
-(define
-  mau/rebuild
-  (fn
-    (f block id)
-    (cond
-      ((empty? block) (if (= id nil) (mau/const "$EMPTY") (mau/const id)))
-      ((empty? (rest block)) (first block))
-      (else (mau/foldr-app f block)))))
-
-(define mau/ac-build (fn (theory f els id) (mau/rebuild f els id)))
-
-;; ---------- AC-canonical form / equality ----------
-
-(define
-  mau/insert-str
-  (fn
-    (x ys)
-    (cond
-      ((empty? ys) (list x))
-      ((<= x (first ys)) (cons x ys))
-      (else (cons (first ys) (mau/insert-str x (rest ys)))))))
-
-(define
-  mau/sort-strings
-  (fn
-    (xs)
-    (if
-      (empty? xs)
-      xs
-      (mau/insert-str (first xs) (mau/sort-strings (rest xs))))))
-
-(define
-  mau/drop-identity
-  (fn
-    (theory f els id)
-    (if
-      (= id nil)
-      els
-      (let
-        ((idc (mau/canon theory (mau/const id))))
-        (filter (fn (e) (not (= (mau/canon theory e) idc))) els)))))
-
-(define
-  mau/canon
-  (fn
-    (theory term)
-    (cond
-      ((mau/var? term) (str "?" (mau/vname term)))
-      ((mau/const? term) (mau/op term))
-      ((mau/app? term)
-        (let
-          ((f (mau/op term)) (th (mau/th-of theory (mau/op term))))
-          (if
-            (get th :assoc)
-            (let
-              ((els (mau/drop-identity theory f (mau/flatten-op theory f term) (get th :id))))
-              (cond
-                ((empty? els)
-                  (if (= (get th :id) nil) "$EMPTY" (get th :id)))
-                ((empty? (rest els)) (mau/canon theory (first els)))
-                (else
-                  (let
-                    ((cs (map (fn (e) (mau/canon theory e)) els)))
-                    (let
-                      ((cs2 (if (get th :comm) (mau/sort-strings cs) cs)))
-                      (str f "(" (join "," cs2) ")"))))))
-            (if
-              (get th :comm)
-              (str
-                f
-                "("
-                (join
-                  ","
-                  (mau/sort-strings
-                    (map (fn (e) (mau/canon theory e)) (mau/args term))))
-                ")")
-              (str
-                f
-                "("
-                (join
-                  ","
-                  (map (fn (e) (mau/canon theory e)) (mau/args term)))
-                ")")))))
-      (else (str term)))))
-
-(define
-  mau/ac-equal?
-  (fn (theory a b) (= (mau/canon theory a) (mau/canon theory b))))
-
-;; ---------- variable block bounds ----------
-
-(define
-  mau/rest-var?
-  (fn
-    (name)
-    (and
-      (> (len name) 0)
-      (= (slice name 0 1) "$"))))
-
-(define
-  mau/var-kmin
-  (fn
-    (name id)
-    (if (or (mau/rest-var? name) (not (= id nil))) 0 1)))
-
-(define
-  mau/bind-check
-  (fn
-    (theory s name val)
-    (let
-      ((b (get s name)))
-      (if
-        (= b nil)
-        (assoc s name val)
-        (if (mau/ac-equal? theory b val) s nil)))))
-
-;; ---------- core multi-valued matcher ----------
-
-(define
-  mau/mm
-  (fn
-    (theory pat subj s)
-    (cond
-      ((mau/var? pat)
-        (let
-          ((bound (get s (mau/vname pat))))
-          (if
-            (= bound nil)
-            (list (assoc s (mau/vname pat) subj))
-            (if (mau/ac-equal? theory bound subj) (list s) (list)))))
-      ((mau/app? pat)
-        (if (mau/app? subj) (mau/mm-app theory pat subj s) (list)))
-      (else (list)))))
-
-(define
-  mau/extend-all
-  (fn
-    (theory p subj substs)
-    (mau/concat-map (fn (s) (mau/mm theory p subj s)) substs)))
-
-(define
-  mau/mm-args
-  (fn
-    (theory ps ss substs)
-    (cond
-      ((and (empty? ps) (empty? ss)) substs)
-      ((or (empty? ps) (empty? ss)) (list))
-      (else
-        (mau/mm-args
-          theory
-          (rest ps)
-          (rest ss)
-          (mau/extend-all theory (first ps) (first ss) substs))))))
-
-(define
-  mau/mm-comm
-  (fn
-    (theory pat subj s)
-    (let
-      ((p1 (nth (mau/args pat) 0))
-        (p2 (nth (mau/args pat) 1))
-        (q1 (nth (mau/args subj) 0))
-        (q2 (nth (mau/args subj) 1)))
-      (mau/append2
-        (mau/mm-args theory (list p1 p2) (list q1 q2) (list s))
-        (mau/mm-args theory (list p1 p2) (list q2 q1) (list s))))))
-
-(define
-  mau/mm-assoc
-  (fn
-    (theory f pat subj s)
-    (let
-      ((pels (mau/flatten-op theory f pat))
-        (sels (mau/flatten-op theory f subj))
-        (th (mau/th-of theory f)))
-      (if
-        (get th :comm)
-        (mau/match-multiset theory f pels sels s (get th :id))
-        (mau/match-sequence theory f pels sels s (get th :id))))))
-
-(define
-  mau/mm-app
-  (fn
-    (theory pat subj s)
-    (let
-      ((f (mau/op pat))
-        (g (mau/op subj))
-        (th (mau/th-of theory (mau/op pat))))
-      (cond
-        ((get th :assoc) (mau/mm-assoc theory f pat subj s))
-        ((get th :comm)
-          (if
-            (and
-              (= f g)
-              (= (mau/arity pat) 2)
-              (= (mau/arity subj) 2))
-            (mau/mm-comm theory pat subj s)
-            (list)))
-        (else
-          (if
-            (and (= f g) (= (mau/arity pat) (mau/arity subj)))
-            (mau/mm-args theory (mau/args pat) (mau/args subj) (list s))
-            (list)))))))
-
-;; ---------- associative (ordered) sequence matching ----------
-
-(define
-  mau/match-sequence
-  (fn
-    (theory f pels sels s id)
-    (cond
-      ((empty? pels) (if (empty? sels) (list s) (list)))
-      (else
-        (let
-          ((p (first pels)) (prest (rest pels)))
-          (if
-            (mau/var? p)
-            (mau/seq-var-loop
-              theory
-              f
-              prest
-              sels
-              s
-              (mau/vname p)
-              id
-              (mau/var-kmin (mau/vname p) id))
-            (if
-              (empty? sels)
-              (list)
-              (mau/concat-map
-                (fn
-                  (s2)
-                  (mau/match-sequence theory f prest (rest sels) s2 id))
-                (mau/mm theory p (first sels) s)))))))))
-
-(define
-  mau/seq-var-loop
-  (fn
-    (theory f prest sels s name id k)
-    (if
-      (> k (len sels))
-      (list)
-      (let
-        ((block (mau/take sels k)) (rests (mau/drop sels k)))
-        (let
-          ((val (mau/rebuild f block id)))
-          (let
-            ((s2 (mau/bind-check theory s name val)))
-            (mau/append2
-              (if
-                (= s2 nil)
-                (list)
-                (mau/match-sequence theory f prest rests s2 id))
-              (mau/seq-var-loop
-                theory
-                f
-                prest
-                sels
-                s
-                name
-                id
-                (+ k 1)))))))))
-
-;; ---------- associative-commutative (multiset) matching ----------
-
-(define
-  mau/match-multiset
-  (fn
-    (theory f pels sels s id)
-    (cond
-      ((empty? pels) (if (empty? sels) (list s) (list)))
-      (else
-        (let
-          ((p (first pels)) (prest (rest pels)))
-          (if
-            (mau/var? p)
-            (mau/ms-var-splits theory f prest sels s (mau/vname p) id)
-            (mau/ms-nonvar-loop theory f p prest sels s id 0)))))))
-
-(define
-  mau/ms-nonvar-loop
-  (fn
-    (theory f p prest sels s id i)
-    (if
-      (>= i (len sels))
-      (list)
-      (let
-        ((elem (nth sels i)) (others (mau/remove-at sels i)))
-        (mau/append2
-          (mau/concat-map
-            (fn (s2) (mau/match-multiset theory f prest others s2 id))
-            (mau/mm theory p elem s))
-          (mau/ms-nonvar-loop theory f p prest sels s id (+ i 1)))))))
-
-(define
-  mau/ms-var-splits
-  (fn
-    (theory f prest sels s name id)
-    (let
-      ((kmin (mau/var-kmin name id)))
-      (mau/concat-map
-        (fn
-          (pair)
-          (let
-            ((chosen (first pair)) (rests (nth pair 1)))
-            (if
-              (< (len chosen) kmin)
-              (list)
-              (let
-                ((val (mau/rebuild f chosen id)))
-                (let
-                  ((s2 (mau/bind-check theory s name val)))
-                  (if
-                    (= s2 nil)
-                    (list)
-                    (mau/match-multiset theory f prest rests s2 id)))))))
-        (mau/all-splits sels)))))
-
-;; ---------- public matching entry ----------
-
-(define
-  mau/match-all
-  (fn (m pat subj) (mau/mm (mau/build-theory m) pat subj {})))
-
-;; ---------- AC-aware equational rewriting ----------
-
-(define
-  mau/restv
-  (fn
-    (theory f s name)
-    (let
-      ((v (get s name)))
-      (cond
-        ((= v nil) (list))
-        ((and (mau/app? v) (= (mau/op v) "$EMPTY")) (list))
-        (else (mau/flatten-op theory f v))))))
-
-(define
-  mau/ac-eq-result
-  (fn
-    (theory f th eq s)
-    (if
-      (get th :comm)
-      (mau/ac-build
-        theory
-        f
-        (mau/append2
-          (mau/flatten-op theory f (mau/subst-apply s (get eq :rhs)))
-          (mau/restv theory f s "$R"))
-        (get th :id))
-      (mau/ac-build
-        theory
-        f
-        (mau/append2
-          (mau/restv theory f s "$L")
-          (mau/append2
-            (mau/flatten-op theory f (mau/subst-apply s (get eq :rhs)))
-            (mau/restv theory f s "$R")))
-        (get th :id)))))
-
-;; Walk the candidate matches and return the first rewrite that actually
-;; changes the term's canonical form (skips idempotency/identity no-ops).
-(define
-  mau/first-change
-  (fn
-    (theory f th eq term matches)
-    (if
-      (empty? matches)
-      nil
-      (let
-        ((result (mau/ac-eq-result theory f th eq (first matches))))
-        (if
-          (mau/ac-equal? theory result term)
-          (mau/first-change theory f th eq term (rest matches))
-          result)))))
-
-(define
-  mau/ac-rewrite-eq
-  (fn
-    (theory f th eq term)
-    (let
-      ((id (get th :id))
-        (pels (mau/flatten-op theory f (get eq :lhs)))
-        (sels (mau/flatten-op theory f term)))
-      (let
-        ((matches (if (get th :comm) (mau/match-multiset theory f (mau/append2 pels (list (mau/var "$R" ""))) sels {} id) (mau/match-sequence theory f (mau/append2 (list (mau/var "$L" "")) (mau/append2 pels (list (mau/var "$R" "")))) sels {} id))))
-        (mau/first-change theory f th eq term matches)))))
-
-(define
-  mau/ac-rewrite-top
-  (fn
-    (theory eqs term)
-    (cond
-      ((empty? eqs) nil)
-      (else
-        (let
-          ((eq (first eqs)))
-          (if
-            (= (get eq :cond) nil)
-            (let
-              ((lhs (get eq :lhs)))
-              (let
-                ((th (if (mau/app? lhs) (mau/th-of theory (mau/op lhs)) {:id nil :assoc false :comm false})))
-                (let
-                  ((r (if (and (mau/app? lhs) (get th :assoc)) (mau/ac-rewrite-eq theory (mau/op lhs) th eq term) (let ((ss (mau/mm theory lhs term {}))) (if (empty? ss) nil (mau/subst-apply (first ss) (get eq :rhs)))))))
-                  (cond
-                    ((= r nil) (mau/ac-rewrite-top theory (rest eqs) term))
-                    ((mau/ac-equal? theory r term)
-                      (mau/ac-rewrite-top theory (rest eqs) term))
-                    (else r)))))
-            (mau/ac-rewrite-top theory (rest eqs) term)))))))
-
-(define
-  mau/ac-normalize
-  (fn
-    (theory eqs term fuel)
-    (if
-      (<= fuel 0)
-      term
-      (cond
-        ((mau/var? term) term)
-        ((mau/app? term)
-          (let
-            ((nargs (map (fn (a) (mau/ac-normalize theory eqs a fuel)) (mau/args term))))
-            (let
-              ((t2 (mau/app (mau/op term) nargs)))
-              (let
-                ((r (mau/ac-rewrite-top theory eqs t2)))
-                (if
-                  (= r nil)
-                  t2
-                  (mau/ac-normalize theory eqs r (- fuel 1)))))))
-        (else term)))))
-
-(define
-  mau/ac-reduce
-  (fn
-    (m term)
-    (mau/ac-normalize
-      (mau/build-theory m)
-      (mau/module-eqs m)
-      term
-      mau/reduce-fuel)))
-
-(define
-  mau/ac-reduce-term
-  (fn (m src) (mau/ac-reduce m (mau/parse-term-in m src))))
-
-(define
-  mau/ac-reduce->str
-  (fn (m src) (mau/term->str (mau/ac-reduce-term m src))))
-
-(define
-  mau/ac-canon
-  (fn (m src) (mau/canon (mau/build-theory m) (mau/ac-reduce-term m src))))

lib/maude/meta.sx

@@ -1,104 +0,0 @@
-;; lib/maude/meta.sx — reflection / META-LEVEL (Phase 7).
-;;
-;; Reflection: a term can be represented AS DATA — another term — and meta-level
-;; functions interpret that representation. In Maude this is the META-LEVEL
-;; (upTerm/downTerm, metaReduce, metaApply, ...). Here object terms are already
-;; SX dicts; the META representation re-encodes a term as a term built from the
-;; meta-constructors `mt-var` and `mt-app`, so a represented term is itself a
-;; first-class object term you can build, inspect, and transform.
-;;
-;;   up-term(X:S)      = mt-var(X, S)            (names/sorts as constants)
-;;   up-term(f(a,b))   = mt-app(f, up(a), up(b))
-;;   down-term reverses.
-;;
-;; Meta-operations reflect object-level behaviour: metaReduce of a represented
-;; term in a module = the representation of its normal form, etc. The
-;; meta-circular law `down(metaReduce(up t)) =AC= reduce t` is exactly the
-;; statement that reflection agrees with the object level.
-
-(define
-  mau/up-term
-  (fn
-    (t)
-    (cond
-      ((mau/var? t)
-        (mau/app
-          "mt-var"
-          (list (mau/const (mau/vname t)) (mau/const (mau/vsort t)))))
-      ((mau/app? t)
-        (mau/app
-          "mt-app"
-          (cons (mau/const (mau/op t)) (map mau/up-term (mau/args t)))))
-      (else t))))
-
-(define
-  mau/down-term
-  (fn
-    (mt)
-    (cond
-      ((and (mau/app? mt) (= (mau/op mt) "mt-var"))
-        (mau/var
-          (mau/op (nth (mau/args mt) 0))
-          (mau/op (nth (mau/args mt) 1))))
-      ((and (mau/app? mt) (= (mau/op mt) "mt-app"))
-        (mau/app
-          (mau/op (first (mau/args mt)))
-          (map mau/down-term (rest (mau/args mt)))))
-      (else mt))))
-
-;; ---- reflective operations (term <-> meta-term) ----
-
-(define
-  mau/meta-reduce
-  (fn (m mt) (mau/up-term (mau/creduce m (mau/down-term mt)))))
-
-(define
-  mau/meta-rewrite
-  (fn (m mt) (mau/up-term (mau/rewrite m (mau/down-term mt)))))
-
-;; apply a named rule once at the top of the represented term; nil if it can't.
-(define
-  mau/meta-apply
-  (fn
-    (m label mt)
-    (let
-      ((theory (mau/build-theory m)) (eqs (mau/module-eqs m)))
-      (let
-        ((r (mau/rules-at-top theory eqs (mau/rules-with-label (mau/module-rules m) label) (mau/down-term mt))))
-        (if
-          (= r nil)
-          nil
-          (mau/up-term (mau/cnormalize theory eqs r mau/reduce-fuel)))))))
-
-;; ---- source-level conveniences ----
-
-(define mau/meta-up (fn (m src) (mau/up-term (mau/parse-term-in m src))))
-
-(define
-  mau/meta-reduce-src
-  (fn (m src) (mau/down-term (mau/meta-reduce m (mau/meta-up m src)))))
-
-(define
-  mau/meta-reduce-canon
-  (fn (m src) (mau/canon (mau/build-theory m) (mau/meta-reduce-src m src))))
-
-;; ---- generic theorem helper: equational proof by reduction ----
-
-(define
-  mau/meta-prove-equal?
-  (fn
-    (m srcA srcB)
-    (mau/ac-equal?
-      (mau/build-theory m)
-      (mau/creduce-term m srcA)
-      (mau/creduce-term m srcB))))
-
-;; meta-circular law: down(metaReduce(up t)) =AC= reduce(t)
-(define
-  mau/meta-circular?
-  (fn
-    (m src)
-    (mau/ac-equal?
-      (mau/build-theory m)
-      (mau/meta-reduce-src m src)
-      (mau/creduce-term m src))))

lib/maude/parser.sx

@@ -1,710 +0,0 @@
-;; lib/maude/parser.sx — Maude module parser.
-;;
-;; Consumes lib/guest/lex.sx (whitespace classes) and lib/guest/pratt.sx
-;; (operator-table lookup), plus lib/maude/term.sx (term constructors).
-;;
-;; Maude tokens are whitespace-delimited words plus the bracketing chars
-;; ( ) [ ] { } , — so an operator name like _+_ or s_ or if_then_else_fi is a
-;; single token. Statements end at a whitespace-delimited "." token.
-;;
-;; Grammar handled here:
-;;   (fmod|mod) NAME is ... (endfm|endm)
-;;   sort/sorts NAMES .
-;;   subsort/subsorts A B < C < D .
-;;   op/ops NAMES : ARITY -> RESULT [ATTRS] .
-;;   var/vars NAMES : SORT .
-;;   eq LHS = RHS [ATTRS] .       ceq LHS = RHS if COND [ATTRS] .
-;;   rl [L] : LHS => RHS .        crl [L] : LHS => RHS if COND .
-;;
-;; Terms: prefix application f(a,b) (op name may contain underscores, e.g.
-;; the prefix form _+_(2,3)); mixfix prefix s_ written `s X`; mixfix infix
-;; _+_ written `X + Y`, parsed by precedence climbing over a table built
-;; from the op declarations. Infix associativity follows `gather`: (E e)=left
-;; (default), (e E)=right (e.g. cons _:_), so `a : b : c` parses right-nested.
-
-;; ---------- tokenizer ----------
-
-(define
-  mau/special-char?
-  (fn
-    (c)
-    (or
-      (= c "(")
-      (= c ")")
-      (= c "[")
-      (= c "]")
-      (= c "{")
-      (= c "}")
-      (= c ","))))
-
-(define
-  mau/tokenize
-  (fn
-    (src)
-    (let
-      ((toks (list)) (pos 0) (n (len src)))
-      (define
-        peekc
-        (fn (o) (if (< (+ pos o) n) (nth src (+ pos o)) nil)))
-      (define curc (fn () (peekc 0)))
-      (define adv! (fn (k) (set! pos (+ pos k))))
-      (define
-        at-comment?
-        (fn
-          ()
-          (or
-            (and
-              (= (curc) "-")
-              (= (peekc 1) "-")
-              (= (peekc 2) "-"))
-            (and
-              (= (curc) "*")
-              (= (peekc 1) "*")
-              (= (peekc 2) "*")))))
-      (define
-        skip-line!
-        (fn
-          ()
-          (when
-            (and (< pos n) (not (= (curc) "\n")))
-            (do (adv! 1) (skip-line!)))))
-      (define
-        read-word!
-        (fn
-          (start)
-          (do
-            (when
-              (and
-                (< pos n)
-                (not (lex-whitespace? (curc)))
-                (not (mau/special-char? (curc))))
-              (do (adv! 1) (read-word! start)))
-            (slice src start pos))))
-      (define
-        scan!
-        (fn
-          ()
-          (cond
-            ((>= pos n) nil)
-            ((lex-whitespace? (curc)) (do (adv! 1) (scan!)))
-            ((at-comment?) (do (skip-line!) (scan!)))
-            ((mau/special-char? (curc))
-              (do (append! toks (curc)) (adv! 1) (scan!)))
-            (else (do (append! toks (read-word! pos)) (scan!))))))
-      (scan!)
-      toks)))
-
-;; ---------- list helpers ----------
-
-(define
-  mau/take
-  (fn
-    (xs k)
-    (if
-      (or (= k 0) (empty? xs))
-      (list)
-      (cons (first xs) (mau/take (rest xs) (- k 1))))))
-
-(define
-  mau/drop
-  (fn
-    (xs k)
-    (if
-      (or (= k 0) (empty? xs))
-      xs
-      (mau/drop (rest xs) (- k 1)))))
-
-(define
-  mau/append2
-  (fn
-    (xs ys)
-    (if (empty? xs) ys (cons (first xs) (mau/append2 (rest xs) ys)))))
-
-(define
-  mau/take-until
-  (fn
-    (xs tok)
-    (if
-      (or (empty? xs) (= (first xs) tok))
-      (list)
-      (cons (first xs) (mau/take-until (rest xs) tok)))))
-
-(define
-  mau/drop-until
-  (fn
-    (xs tok)
-    (cond
-      ((empty? xs) (list))
-      ((= (first xs) tok) xs)
-      (else (mau/drop-until (rest xs) tok)))))
-
-;; ---------- mixfix classification ----------
-
-(define
-  mau/op-form
-  (fn
-    (name)
-    (let
-      ((parts (split name "_")))
-      (cond
-        ((= (len parts) 1) {:kind :const :token name})
-        ((and (= (len parts) 3) (= (nth parts 0) "") (= (nth parts 2) "") (not (= (nth parts 1) "")))
-          {:kind :infix :token (nth parts 1)})
-        ((and (= (len parts) 2) (not (= (nth parts 0) "")) (= (nth parts 1) ""))
-          {:kind :prefix :token (nth parts 0)})
-        ((and (= (len parts) 2) (= (nth parts 0) "") (not (= (nth parts 1) "")))
-          {:kind :postfix :token (nth parts 1)})
-        (else {:kind :mixfix :token name})))))
-
-(define
-  mau/default-prec
-  (fn
-    (kind)
-    (cond
-      ((= kind "infix") 41)
-      ((= kind "prefix") 15)
-      ((= kind "postfix") 15)
-      (else 0))))
-
-(define
-  mau/op-prec
-  (fn
-    (op form)
-    (let
-      ((p (get (get op :attrs) :prec)))
-      (if (= p nil) (mau/default-prec (get form :kind)) p))))
-
-;; parse associativity from a gather spec: (E e)=left, (e E)=right.
-(define
-  mau/gather-assoc
-  (fn
-    (attrs)
-    (let
-      ((g (get attrs :gather)))
-      (if
-        (or (= g nil) (< (len g) 2))
-        "left"
-        (cond
-          ((= (nth g 1) "E") "right")
-          ((= (nth g 0) "E") "left")
-          (else "left"))))))
-
-(define
-  mau/build-infix-table
-  (fn
-    (ops)
-    (if
-      (empty? ops)
-      (list)
-      (let
-        ((op (first ops)) (rest-tbl (mau/build-infix-table (rest ops))))
-        (let
-          ((form (mau/op-form (get op :name))))
-          (if
-            (= (get form :kind) "infix")
-            (cons
-              (list
-                (get form :token)
-                (mau/op-prec op form)
-                (get op :name)
-                (mau/gather-assoc (get op :attrs)))
-              rest-tbl)
-            rest-tbl))))))
-
-(define
-  mau/build-prefix-table
-  (fn
-    (ops)
-    (if
-      (empty? ops)
-      (list)
-      (let
-        ((op (first ops)) (rest-tbl (mau/build-prefix-table (rest ops))))
-        (let
-          ((form (mau/op-form (get op :name))))
-          (if
-            (= (get form :kind) "prefix")
-            (cons
-              (list (get form :token) (mau/op-prec op form) (get op :name))
-              rest-tbl)
-            rest-tbl))))))
-
-;; ---------- term parsing ----------
-
-(define mau/has-colon? (fn (tok) (contains? tok ":")))
-
-(define
-  mau/atom->term
-  (fn
-    (tok vars)
-    (cond
-      ((mau/has-colon? tok)
-        (let
-          ((parts (split tok ":")))
-          (mau/var (nth parts 0) (nth parts 1))))
-      ((not (= (get vars tok) nil)) (mau/var tok (get vars tok)))
-      (else (mau/const tok)))))
-
-(define
-  mau/parse-term
-  (fn
-    (toks grammar)
-    (let
-      ((ts toks)
-        (pos 0)
-        (n (len toks))
-        (infix-tbl (get grammar :infix))
-        (prefix-tbl (get grammar :prefix))
-        (vars (get grammar :vars))
-        (prefix-rbp 1000))
-      (define tcur (fn () (if (< pos n) (nth ts pos) nil)))
-      (define
-        tpeek
-        (fn (o) (if (< (+ pos o) n) (nth ts (+ pos o)) nil)))
-      (define tadv! (fn () (set! pos (+ pos 1))))
-      (define
-        parse-args
-        (fn
-          ()
-          (if
-            (= (tcur) ")")
-            (do (tadv!) (list))
-            (let
-              ((acc (list)))
-              (define
-                more
-                (fn
-                  ()
-                  (do
-                    (append! acc (parse-expr 0))
-                    (when (= (tcur) ",") (do (tadv!) (more))))))
-              (do (more) (when (= (tcur) ")") (tadv!)) acc)))))
-      (define
-        parse-primary
-        (fn
-          ()
-          (let
-            ((t (tcur)))
-            (cond
-              ((= t "(")
-                (do
-                  (tadv!)
-                  (let
-                    ((e (parse-expr 0)))
-                    (do (when (= (tcur) ")") (tadv!)) e))))
-              ((not (= (pratt-op-lookup prefix-tbl t) nil))
-                (let
-                  ((entry (pratt-op-lookup prefix-tbl t)))
-                  (do
-                    (tadv!)
-                    (let
-                      ((operand (parse-expr prefix-rbp)))
-                      (mau/app (nth entry 2) (list operand))))))
-              ((= (tpeek 1) "(")
-                (let
-                  ((name t))
-                  (do (tadv!) (tadv!) (mau/app name (parse-args)))))
-              (else (do (tadv!) (mau/atom->term t vars)))))))
-      (define
-        parse-expr
-        (fn
-          (minbp)
-          (let
-            ((lhs (parse-primary)))
-            (define
-              climb
-              (fn
-                (acc)
-                (let
-                  ((t (tcur)))
-                  (let
-                    ((entry (if (= t nil) nil (pratt-op-lookup infix-tbl t))))
-                    (if
-                      (= entry nil)
-                      acc
-                      (let
-                        ((lbp (pratt-op-prec entry)))
-                        (if
-                          (< lbp minbp)
-                          acc
-                          (do
-                            (tadv!)
-                            (let
-                              ((rbp (if (= (nth entry 3) "right") lbp (+ lbp 1))))
-                              (let
-                                ((rhs (parse-expr rbp)))
-                                (climb
-                                  (mau/app
-                                    (nth entry 2)
-                                    (list acc rhs)))))))))))))
-            (climb lhs))))
-      (parse-expr 0))))
-
-;; ---------- statement splitting ----------
-
-(define
-  mau/split-statements
-  (fn
-    (toks)
-    (let
-      ((stmts (list)) (cur (list)))
-      (define
-        flush!
-        (fn
-          ()
-          (when
-            (not (empty? cur))
-            (do (append! stmts cur) (set! cur (list))))))
-      (define
-        loop
-        (fn
-          (ts)
-          (cond
-            ((empty? ts) (flush!))
-            ((= (first ts) ".") (do (flush!) (loop (rest ts))))
-            (else (do (append! cur (first ts)) (loop (rest ts)))))))
-      (do (loop toks) stmts))))
-
-(define
-  mau/split-groups
-  (fn
-    (toks)
-    (let
-      ((groups (list)) (cur (list)))
-      (define flush! (fn () (do (append! groups cur) (set! cur (list)))))
-      (define
-        loop
-        (fn
-          (ts)
-          (cond
-            ((empty? ts) (flush!))
-            ((= (first ts) "<") (do (flush!) (loop (rest ts))))
-            (else (do (append! cur (first ts)) (loop (rest ts)))))))
-      (do (loop toks) groups))))
-
-;; ---------- attributes ----------
-
-(define mau/strip-brackets (fn (toks) (mau/take-until (rest toks) "]")))
-
-(define
-  mau/parse-attr-tokens
-  (fn
-    (toks)
-    (let
-      ((acc {}))
-      (define
-        loop
-        (fn
-          (ts)
-          (cond
-            ((empty? ts) nil)
-            ((= (first ts) "assoc")
-              (do (dict-set! acc :assoc true) (loop (rest ts))))
-            ((= (first ts) "comm")
-              (do (dict-set! acc :comm true) (loop (rest ts))))
-            ((or (= (first ts) "idem") (= (first ts) "idempotent"))
-              (do (dict-set! acc :idem true) (loop (rest ts))))
-            ((= (first ts) "ctor")
-              (do (dict-set! acc :ctor true) (loop (rest ts))))
-            ((= (first ts) "owise")
-              (do (dict-set! acc :owise true) (loop (rest ts))))
-            ((= (first ts) "id:")
-              (do
-                (dict-set! acc :id (nth ts 1))
-                (loop (mau/drop ts 2))))
-            ((= (first ts) "prec")
-              (do
-                (dict-set! acc :prec (parse-number (nth ts 1)))
-                (loop (mau/drop ts 2))))
-            ((= (first ts) "label")
-              (do
-                (dict-set! acc :label (nth ts 1))
-                (loop (mau/drop ts 2))))
-            ((= (first ts) "gather")
-              (let
-                ((after2 (mau/drop ts 2)))
-                (do
-                  (dict-set! acc :gather (mau/take-until after2 ")"))
-                  (loop (rest (mau/drop-until after2 ")"))))))
-            (else (loop (rest ts))))))
-      (do (loop toks) acc))))
-
-(define
-  mau/parse-attrs
-  (fn
-    (toks)
-    (if
-      (or (empty? toks) (not (= (first toks) "[")))
-      {}
-      (mau/parse-attr-tokens (mau/strip-brackets toks)))))
-
-;; Split a token sequence into {:term tokens-before-bracket :attrs parsed}.
-(define mau/split-attrs (fn (toks) {:attrs (mau/parse-attrs (mau/drop-until toks "[")) :term (mau/take-until toks "[")}))
-
-;; ---------- signature collection ----------
-
-(define
-  mau/append-each!
-  (fn (acc xs) (for-each (fn (x) (append! acc x)) xs)))
-
-(define
-  mau/register-ops!
-  (fn
-    (ops names arity result attrs)
-    (for-each (fn (nm) (append! ops {:name nm :attrs attrs :arity arity :result result})) names)))
-
-(define
-  mau/each-set-var!
-  (fn
-    (vars names sort)
-    (for-each (fn (nm) (dict-set! vars nm sort)) names)))
-
-(define
-  mau/cross-append!
-  (fn
-    (acc g1 g2)
-    (for-each
-      (fn
-        (sub)
-        (for-each (fn (super) (append! acc (list sub super))) g2))
-      g1)))
-
-(define
-  mau/add-subsort-chain!
-  (fn
-    (acc groups)
-    (when
-      (and (not (empty? groups)) (not (empty? (rest groups))))
-      (do
-        (mau/cross-append! acc (first groups) (nth groups 1))
-        (mau/add-subsort-chain! acc (rest groups))))))
-
-(define
-  mau/add-subsorts!
-  (fn (acc body) (mau/add-subsort-chain! acc (mau/split-groups body))))
-
-(define
-  mau/add-vars!
-  (fn
-    (vars body)
-    (let
-      ((names (mau/take-until body ":"))
-        (sort (first (rest (mau/drop-until body ":")))))
-      (mau/each-set-var! vars names sort))))
-
-(define
-  mau/add-ops!
-  (fn
-    (ops body)
-    (let
-      ((names (mau/take-until body ":"))
-        (afterc (rest (mau/drop-until body ":"))))
-      (let
-        ((arity (mau/take-until afterc "->"))
-          (aftera (rest (mau/drop-until afterc "->"))))
-        (let
-          ((result (first aftera))
-            (attrs (mau/parse-attrs (mau/drop aftera 1))))
-          (mau/register-ops! ops names arity result attrs))))))
-
-(define
-  mau/collect-sig!
-  (fn
-    (stmts sorts subsorts ops vars)
-    (for-each
-      (fn
-        (s)
-        (let
-          ((head (first s)) (body (rest s)))
-          (cond
-            ((or (= head "sort") (= head "sorts"))
-              (mau/append-each! sorts body))
-            ((or (= head "subsort") (= head "subsorts"))
-              (mau/add-subsorts! subsorts body))
-            ((or (= head "op") (= head "ops")) (mau/add-ops! ops body))
-            ((or (= head "var") (= head "vars")) (mau/add-vars! vars body))
-            (else nil))))
-      stmts)))
-
-;; ---------- equations / rules ----------
-
-(define
-  mau/parse-cond
-  (fn
-    (toks grammar)
-    (if
-      (mau/member? "=" toks)
-      (let
-        ((l (mau/take-until toks "="))
-          (r (rest (mau/drop-until toks "="))))
-        {:lhs (mau/parse-term l grammar) :kind :eq :rhs (mau/parse-term r grammar)})
-      {:kind :bool :term (mau/parse-term toks grammar)})))
-
-(define
-  mau/parse-eq
-  (fn
-    (body grammar conditional?)
-    (let
-      ((lhs-toks (mau/take-until body "="))
-        (after (rest (mau/drop-until body "="))))
-      (if
-        conditional?
-        (let
-          ((rhs-toks (mau/take-until after "if"))
-            (cond-raw (rest (mau/drop-until after "if"))))
-          (let ((csplit (mau/split-attrs cond-raw))) {:lhs (mau/parse-term lhs-toks grammar) :t :eq :cond (mau/parse-cond (get csplit :term) grammar) :rhs (mau/parse-term rhs-toks grammar) :owise (= (get (get csplit :attrs) :owise) true)}))
-        (let ((rsplit (mau/split-attrs after))) {:lhs (mau/parse-term lhs-toks grammar) :t :eq :cond nil :rhs (mau/parse-term (get rsplit :term) grammar) :owise (= (get (get rsplit :attrs) :owise) true)})))))
-
-(define
-  mau/strip-label
-  (fn
-    (body)
-    (if
-      (and (not (empty? body)) (= (first body) "["))
-      (let
-        ((label (nth body 1)) (after (mau/drop body 3)))
-        (if
-          (and (not (empty? after)) (= (first after) ":"))
-          {:label label :rest (rest after)}
-          {:label label :rest after}))
-      {:label nil :rest body})))
-
-(define
-  mau/parse-rule
-  (fn
-    (body grammar conditional?)
-    (let
-      ((b (mau/strip-label body)))
-      (let
-        ((label (get b :label)) (rest-toks (get b :rest)))
-        (let
-          ((lhs-toks (mau/take-until rest-toks "=>"))
-            (after (rest (mau/drop-until rest-toks "=>"))))
-          (if
-            conditional?
-            (let
-              ((rhs-toks (mau/take-until after "if"))
-                (cond-toks (rest (mau/drop-until after "if"))))
-              {:lhs (mau/parse-term lhs-toks grammar) :label label :t :rule :cond (mau/parse-cond (get (mau/split-attrs cond-toks) :term) grammar) :rhs (mau/parse-term rhs-toks grammar)})
-            {:lhs (mau/parse-term lhs-toks grammar) :label label :t :rule :cond nil :rhs (mau/parse-term (get (mau/split-attrs after) :term) grammar)}))))))
-
-(define
-  mau/collect-rules!
-  (fn
-    (stmts grammar eqs rules)
-    (for-each
-      (fn
-        (s)
-        (let
-          ((head (first s)) (body (rest s)))
-          (cond
-            ((= head "eq") (append! eqs (mau/parse-eq body grammar false)))
-            ((= head "ceq") (append! eqs (mau/parse-eq body grammar true)))
-            ((= head "rl")
-              (append! rules (mau/parse-rule body grammar false)))
-            ((= head "crl")
-              (append! rules (mau/parse-rule body grammar true)))
-            (else nil))))
-      stmts)))
-
-;; ---------- module assembly ----------
-
-(define mau/make-grammar (fn (ops vars) {:prefix (mau/build-prefix-table ops) :ops ops :vars vars :infix (mau/build-infix-table ops)}))
-
-(define
-  mau/build-module
-  (fn
-    (kind name body)
-    (let
-      ((stmts (mau/split-statements body))
-        (sorts (list))
-        (subsorts (list))
-        (ops (list))
-        (vars {})
-        (eqs (list))
-        (rules (list)))
-      (mau/collect-sig! stmts sorts subsorts ops vars)
-      (let
-        ((grammar (mau/make-grammar ops vars)))
-        (mau/collect-rules! stmts grammar eqs rules)
-        {:name name :grammar grammar :sorts sorts :eqs eqs :ops ops :t :module :vars vars :subsorts subsorts :kind kind :rules rules}))))
-
-(define
-  mau/parse-module
-  (fn
-    (src)
-    (let
-      ((toks (mau/tokenize src)))
-      (let
-        ((kind (nth toks 0)) (name (nth toks 1)))
-        (let
-          ((body (mau/take (mau/drop toks 3) (- (len toks) 4))))
-          (mau/build-module kind name body))))))
-
-;; ---------- signature queries ----------
-
-(define mau/module-name (fn (m) (get m :name)))
-(define mau/module-kind (fn (m) (get m :kind)))
-(define mau/module-sorts (fn (m) (get m :sorts)))
-(define mau/module-subsorts (fn (m) (get m :subsorts)))
-(define mau/module-ops (fn (m) (get m :ops)))
-(define mau/module-vars (fn (m) (get m :vars)))
-(define mau/module-eqs (fn (m) (get m :eqs)))
-(define mau/module-rules (fn (m) (get m :rules)))
-(define mau/module-grammar (fn (m) (get m :grammar)))
-
-(define
-  mau/parse-term-in
-  (fn (m src) (mau/parse-term (mau/tokenize src) (mau/module-grammar m))))
-
-(define
-  mau/collect-supers
-  (fn
-    (pairs s)
-    (cond
-      ((empty? pairs) (list))
-      ((= (first (first pairs)) s)
-        (cons
-          (nth (first pairs) 1)
-          (mau/collect-supers (rest pairs) s)))
-      (else (mau/collect-supers (rest pairs) s)))))
-
-(define mau/supers-of (fn (m s) (mau/collect-supers (get m :subsorts) s)))
-
-(define
-  mau/dfs-reach
-  (fn
-    (m frontier target seen)
-    (cond
-      ((empty? frontier) false)
-      ((= (first frontier) target) true)
-      ((mau/member? (first frontier) seen)
-        (mau/dfs-reach m (rest frontier) target seen))
-      (else
-        (mau/dfs-reach
-          m
-          (mau/append2 (mau/supers-of m (first frontier)) (rest frontier))
-          target
-          (cons (first frontier) seen))))))
-
-(define
-  mau/subsort?
-  (fn
-    (m sub super)
-    (mau/dfs-reach m (mau/supers-of m sub) super (list sub))))
-
-(define mau/sort<=? (fn (m a b) (or (= a b) (mau/subsort? m a b))))
-
-(define
-  mau/filter-ops
-  (fn
-    (ops name)
-    (cond
-      ((empty? ops) (list))
-      ((= (get (first ops) :name) name)
-        (cons (first ops) (mau/filter-ops (rest ops) name)))
-      (else (mau/filter-ops (rest ops) name)))))
-
-(define
-  mau/ops-named
-  (fn (m name) (mau/filter-ops (mau/module-ops m) name)))

lib/maude/pretty.sx

@@ -1,82 +0,0 @@
-;; lib/maude/pretty.sx — mixfix surface-syntax printer.
-;;
-;; term->str renders the internal prefix form (`_+_(s_(X), 0)`); this renders
-;; terms back in Maude mixfix surface syntax (`((s X) + 0)`), driven by the
-;; operator forms in the module signature. Fully parenthesised — unambiguous
-;; rather than minimal. Constants and unknown ops fall back to prefix form.
-
-(define
-  mau/render-forms
-  (fn
-    (m)
-    (let
-      ((tbl {}))
-      (for-each
-        (fn
-          (op)
-          (dict-set! tbl (get op :name) (mau/op-form (get op :name))))
-        (mau/module-ops m))
-      tbl)))
-
-(define
-  mau/render-args
-  (fn
-    (forms args)
-    (cond
-      ((empty? args) "")
-      ((empty? (rest args)) (mau/render-term forms (first args)))
-      (else
-        (str
-          (mau/render-term forms (first args))
-          ", "
-          (mau/render-args forms (rest args)))))))
-
-(define
-  mau/render-term
-  (fn
-    (forms t)
-    (cond
-      ((mau/var? t) (mau/vname t))
-      ((mau/app? t)
-        (let
-          ((form (get forms (mau/op t))) (args (mau/args t)))
-          (cond
-            ((empty? args) (mau/op t))
-            ((and form (= (get form :kind) "infix") (= (len args) 2))
-              (str
-                "("
-                (mau/render-term forms (nth args 0))
-                " "
-                (get form :token)
-                " "
-                (mau/render-term forms (nth args 1))
-                ")"))
-            ((and form (= (get form :kind) "prefix") (= (len args) 1))
-              (str
-                "("
-                (get form :token)
-                " "
-                (mau/render-term forms (first args))
-                ")"))
-            ((and form (= (get form :kind) "postfix") (= (len args) 1))
-              (str
-                "("
-                (mau/render-term forms (first args))
-                " "
-                (get form :token)
-                ")"))
-            (else (str (mau/op t) "(" (mau/render-args forms args) ")")))))
-      (else (str t)))))
-
-(define
-  mau/term->maude
-  (fn (m t) (mau/render-term (mau/render-forms m) t)))
-
-;; reduce / rewrite then render in surface syntax
-(define
-  mau/red->maude
-  (fn (m src) (mau/term->maude m (mau/creduce-term m src))))
-
-(define
-  mau/rew->maude
-  (fn (m src) (mau/term->maude m (mau/rewrite-term m src))))

lib/maude/reduce.sx

@@ -1,143 +0,0 @@
-;; lib/maude/reduce.sx — syntactic equational reduction (Phase 2).
-;;
-;; Apply unconditional equations left-to-right to a fixpoint, using strict
-;; one-sided syntactic matching (no theories yet — assoc/comm/id come in
-;; Phase 3). Reduction is innermost: arguments are normalised before the
-;; enclosing operator is rewritten.
-;;
-;; A substitution is a dict VAR-NAME -> term, extended immutably via `assoc`.
-;; Matching is one-sided: only the pattern (equation LHS) carries variables;
-;; the subject is treated structurally.
-
-;; ---------- matching ----------
-
-(define
-  mau/match
-  (fn
-    (pat subj s)
-    (cond
-      ((= s nil) nil)
-      ((mau/var? pat)
-        (let
-          ((bound (get s (mau/vname pat))))
-          (if
-            (= bound nil)
-            (assoc s (mau/vname pat) subj)
-            (if (mau/term=? bound subj) s nil))))
-      ((and (mau/app? pat) (mau/app? subj))
-        (if
-          (and
-            (= (mau/op pat) (mau/op subj))
-            (= (mau/arity pat) (mau/arity subj)))
-          (mau/match-args (mau/args pat) (mau/args subj) s)
-          nil))
-      (else nil))))
-
-(define
-  mau/match-args
-  (fn
-    (ps ss s)
-    (cond
-      ((= s nil) nil)
-      ((and (empty? ps) (empty? ss)) s)
-      ((or (empty? ps) (empty? ss)) nil)
-      (else
-        (mau/match-args
-          (rest ps)
-          (rest ss)
-          (mau/match (first ps) (first ss) s))))))
-
-;; ---------- substitution application ----------
-
-(define
-  mau/subst-apply-list
-  (fn
-    (s args)
-    (if
-      (empty? args)
-      (list)
-      (cons
-        (mau/subst-apply s (first args))
-        (mau/subst-apply-list s (rest args))))))
-
-(define
-  mau/subst-apply
-  (fn
-    (s term)
-    (cond
-      ((mau/var? term)
-        (let ((b (get s (mau/vname term)))) (if (= b nil) term b)))
-      ((mau/app? term)
-        (mau/app (mau/op term) (mau/subst-apply-list s (mau/args term))))
-      (else term))))
-
-;; ---------- top-level rewrite ----------
-
-;; Try each unconditional equation in order; on the first whose LHS matches
-;; the term, return the instantiated RHS. nil if none apply.
-(define
-  mau/rewrite-top
-  (fn
-    (eqs term)
-    (cond
-      ((empty? eqs) nil)
-      (else
-        (let
-          ((eq (first eqs)))
-          (if
-            (= (get eq :cond) nil)
-            (let
-              ((s (mau/match (get eq :lhs) term {})))
-              (if
-                (= s nil)
-                (mau/rewrite-top (rest eqs) term)
-                (mau/subst-apply s (get eq :rhs))))
-            (mau/rewrite-top (rest eqs) term)))))))
-
-;; ---------- normalisation (innermost to fixpoint) ----------
-
-(define
-  mau/normalize-args
-  (fn
-    (eqs args fuel)
-    (if
-      (empty? args)
-      (list)
-      (cons
-        (mau/normalize eqs (first args) fuel)
-        (mau/normalize-args eqs (rest args) fuel)))))
-
-(define
-  mau/normalize
-  (fn
-    (eqs term fuel)
-    (if
-      (<= fuel 0)
-      term
-      (cond
-        ((mau/var? term) term)
-        ((mau/app? term)
-          (let
-            ((nargs (mau/normalize-args eqs (mau/args term) fuel)))
-            (let
-              ((t2 (mau/app (mau/op term) nargs)))
-              (let
-                ((r (mau/rewrite-top eqs t2)))
-                (if (= r nil) t2 (mau/normalize eqs r (- fuel 1)))))))
-        (else term)))))
-
-;; ---------- module-level API ----------
-
-(define mau/reduce-fuel 1000000)
-
-(define
-  mau/reduce
-  (fn (m term) (mau/normalize (mau/module-eqs m) term mau/reduce-fuel)))
-
-(define
-  mau/reduce-term
-  (fn (m src) (mau/reduce m (mau/parse-term-in m src))))
-
-(define
-  mau/reduce->str
-  (fn (m src) (mau/term->str (mau/reduce-term m src))))

lib/maude/rewrite.sx

@@ -1,284 +0,0 @@
-;; lib/maude/rewrite.sx — system modules + rewrite rules (Phase 5).
-;;
-;; Equations (eq/ceq) are applied to a fixpoint to NORMALISE (confluent by
-;; intent). Rules (rl/crl) are TRANSITIONS: asymmetric (=>), possibly
-;; nondeterministic, NOT applied to a fixpoint. Maude's `rew` interleaves
-;; the two: normalise with equations, fire one rule, renormalise, repeat.
-;;
-;; Rule firing reuses the shared firing machinery — a rule dict carries
-;; :lhs/:rhs/:cond exactly like an equation, so `mau/fire-eq` (short-circuit,
-;; fire.sx) applies unchanged (matching modulo the AC theory; crl guards
-;; evaluated with the equations). A rule fires only if it both progresses and
-;; its condition holds.
-;;
-;; `mau/rewrite` follows the default strategy (top-down, leftmost-outermost,
-;; first applicable rule) for one path. `mau/search` does breadth-first reach
-;; over ALL one-step successors — for puzzle solvers / protocol simulators
-;; where the answer is on a branch `rew` would not take.
-
-(define mau/rew-fuel 100000)
-
-;; ---- single-step, default strategy (first applicable, leftmost-outermost) ----
-
-(define
-  mau/rules-at-top
-  (fn
-    (theory eqs rules term)
-    (if
-      (empty? rules)
-      nil
-      (let
-        ((r (mau/fire-eq theory eqs (first rules) term)))
-        (if (= r nil) (mau/rules-at-top theory eqs (rest rules) term) r)))))
-
-(define
-  mau/apply-rule-once
-  (fn
-    (theory eqs rules term)
-    (let
-      ((top (mau/rules-at-top theory eqs rules term)))
-      (if
-        (not (= top nil))
-        top
-        (if
-          (mau/app? term)
-          (mau/apply-rule-in-args
-            theory
-            eqs
-            rules
-            (mau/op term)
-            (mau/args term)
-            (list))
-          nil)))))
-
-(define
-  mau/apply-rule-in-args
-  (fn
-    (theory eqs rules op done todo)
-    (if
-      (empty? todo)
-      nil
-      (let
-        ((r (mau/apply-rule-once theory eqs rules (first todo))))
-        (if
-          (= r nil)
-          (mau/apply-rule-in-args
-            theory
-            eqs
-            rules
-            op
-            (mau/append2 done (list (first todo)))
-            (rest todo))
-          (mau/app op (mau/append2 done (cons r (rest todo)))))))))
-
-(define
-  mau/rewrite-steps
-  (fn
-    (theory eqs rules term steps)
-    (if
-      (<= steps 0)
-      (mau/cnormalize theory eqs term mau/reduce-fuel)
-      (let
-        ((nf (mau/cnormalize theory eqs term mau/reduce-fuel)))
-        (let
-          ((r (mau/apply-rule-once theory eqs rules nf)))
-          (if
-            (= r nil)
-            nf
-            (mau/rewrite-steps theory eqs rules r (- steps 1))))))))
-
-(define
-  mau/rewrite
-  (fn
-    (m term)
-    (mau/rewrite-steps
-      (mau/build-theory m)
-      (mau/module-eqs m)
-      (mau/module-rules m)
-      term
-      mau/rew-fuel)))
-
-(define
-  mau/rew
-  (fn
-    (m src n)
-    (mau/rewrite-steps
-      (mau/build-theory m)
-      (mau/module-eqs m)
-      (mau/module-rules m)
-      (mau/parse-term-in m src)
-      n)))
-
-(define
-  mau/rewrite-term
-  (fn (m src) (mau/rewrite m (mau/parse-term-in m src))))
-
-(define
-  mau/rewrite->str
-  (fn (m src) (mau/term->str (mau/rewrite-term m src))))
-
-(define
-  mau/rewrite-canon
-  (fn (m src) (mau/canon (mau/build-theory m) (mau/rewrite-term m src))))
-
-(define mau/rew->str (fn (m src n) (mau/term->str (mau/rew m src n))))
-
-(define
-  mau/rew-canon
-  (fn (m src n) (mau/canon (mau/build-theory m) (mau/rew m src n))))
-
-;; ---- all one-step successors (for search; eager enumeration) ----
-
-(define
-  mau/cands-results
-  (fn
-    (theory eqs cond term cands)
-    (mau/concat-map
-      (fn
-        (c)
-        (if
-          (and
-            (not (mau/ac-equal? theory (get c :result) term))
-            (mau/cond-holds? theory eqs cond (get c :s)))
-          (list (mau/cnormalize theory eqs (get c :result) mau/reduce-fuel))
-          (list)))
-      cands)))
-
-(define
-  mau/top-successors
-  (fn
-    (theory eqs rules term)
-    (mau/concat-map
-      (fn
-        (rule)
-        (mau/cands-results
-          theory
-          eqs
-          (get rule :cond)
-          term
-          (mau/eq-candidates theory rule term)))
-      rules)))
-
-(define
-  mau/arg-successors
-  (fn
-    (theory eqs rules op done todo)
-    (if
-      (empty? todo)
-      (list)
-      (mau/append2
-        (map
-          (fn
-            (sub)
-            (mau/app op (mau/append2 done (cons sub (rest todo)))))
-          (mau/all-successors theory eqs rules (first todo)))
-        (mau/arg-successors
-          theory
-          eqs
-          rules
-          op
-          (mau/append2 done (list (first todo)))
-          (rest todo))))))
-
-(define
-  mau/all-successors
-  (fn
-    (theory eqs rules term)
-    (mau/append2
-      (mau/top-successors theory eqs rules term)
-      (if
-        (mau/app? term)
-        (mau/arg-successors
-          theory
-          eqs
-          rules
-          (mau/op term)
-          (mau/args term)
-          (list))
-        (list)))))
-
-(define
-  mau/successors
-  (fn
-    (m src)
-    (let
-      ((theory (mau/build-theory m)) (eqs (mau/module-eqs m)))
-      (map
-        (fn (t) (mau/canon theory t))
-        (mau/all-successors
-          theory
-          eqs
-          (mau/module-rules m)
-          (mau/cnormalize
-            theory
-            eqs
-            (mau/parse-term-in m src)
-            mau/reduce-fuel))))))
-
-;; ---- breadth-first reachability search ----
-
-(define
-  mau/canon-list
-  (fn (theory ts) (map (fn (t) (mau/canon theory t)) ts)))
-
-(define
-  mau/bfs-search
-  (fn
-    (theory eqs rules frontier seen goal depth)
-    (cond
-      ((mau/member? goal (mau/canon-list theory frontier)) true)
-      ((<= depth 0) false)
-      ((empty? frontier) false)
-      (else
-        (let
-          ((newf (list)) (newseen seen))
-          (for-each
-            (fn
-              (t)
-              (for-each
-                (fn
-                  (succ)
-                  (let
-                    ((c (mau/canon theory succ)))
-                    (when
-                      (not (mau/member? c newseen))
-                      (do
-                        (set! newseen (cons c newseen))
-                        (append! newf succ)))))
-                (mau/all-successors theory eqs rules t)))
-            frontier)
-          (mau/bfs-search
-            theory
-            eqs
-            rules
-            newf
-            newseen
-            goal
-            (- depth 1)))))))
-
-(define
-  mau/search
-  (fn
-    (m start-src goal-src max-depth)
-    (let
-      ((theory (mau/build-theory m))
-        (eqs (mau/module-eqs m))
-        (rules (mau/module-rules m)))
-      (let
-        ((start (mau/cnormalize theory eqs (mau/parse-term-in m start-src) mau/reduce-fuel))
-          (goal
-            (mau/canon
-              theory
-              (mau/cnormalize
-                theory
-                eqs
-                (mau/parse-term-in m goal-src)
-                mau/reduce-fuel))))
-        (mau/bfs-search
-          theory
-          eqs
-          rules
-          (list start)
-          (list (mau/canon theory start))
-          goal
-          max-depth)))))

lib/maude/run.sx

@@ -1,132 +0,0 @@
-;; lib/maude/run.sx — run a Maude program: a module followed by commands.
-;;
-;; Parses a single fmod/mod ... endfm/endm module plus trailing commands and
-;; executes them, Maude-style:
-;;   reduce TERM .   (alias: red)   — normalise with equations
-;;   rewrite TERM .  (alias: rew)   — apply rules under the default strategy
-;;   search START =>* GOAL .         — reachability (=>*, =>+, =>! all treated
-;;                                     as reachability); reports the path
-;; `... in MODNAME : TERM .` is accepted (the module qualifier is ignored —
-;; there is one module in scope). reduce/rewrite results carry the least sort,
-;; rendered Maude-style by mau/run-pretty as `result SORT: TERM`.
-
-(define mau/search-depth 200)
-
-(define
-  mau/module-end-idx
-  (fn
-    (toks i)
-    (cond
-      ((>= i (len toks)) (- 0 1))
-      ((or (= (nth toks i) "endfm") (= (nth toks i) "endm")) i)
-      (else (mau/module-end-idx toks (+ i 1))))))
-
-(define
-  mau/parse-module-from-toks
-  (fn
-    (toks)
-    (let
-      ((kind (nth toks 0)) (name (nth toks 1)))
-      (mau/build-module
-        kind
-        name
-        (mau/take (mau/drop toks 3) (- (len toks) 4))))))
-
-(define
-  mau/strip-in
-  (fn
-    (toks)
-    (if
-      (and (not (empty? toks)) (= (first toks) "in"))
-      (rest (mau/drop-until toks ":"))
-      toks)))
-
-(define
-  mau/find-arrow
-  (fn
-    (toks)
-    (cond
-      ((empty? toks) nil)
-      ((and (>= (len (first toks)) 2) (= (slice (first toks) 0 2) "=>"))
-        (first toks))
-      (else (mau/find-arrow (rest toks))))))
-
-(define
-  mau/run-search
-  (fn
-    (m term-toks)
-    (let
-      ((arrow (mau/find-arrow term-toks)) (g (mau/module-grammar m)))
-      (if
-        (= arrow nil)
-        {:path nil :cmd "search" :result "no arrow"}
-        (let
-          ((start-toks (mau/take-until term-toks arrow))
-            (goal-toks (rest (mau/drop-until term-toks arrow))))
-          (let
-            ((path (mau/search-path-terms m (mau/parse-term start-toks g) (mau/parse-term goal-toks g) mau/search-depth)))
-            {:path path :cmd "search" :result (if (= path nil) "no solution" (join " => " path))}))))))
-
-(define
-  mau/run-command
-  (fn
-    (m stmt)
-    (let
-      ((head (first stmt)))
-      (if
-        (or (= head "search") (= head "srch"))
-        (mau/run-search m (rest stmt))
-        (let
-          ((t (mau/parse-term (mau/strip-in (rest stmt)) (mau/module-grammar m))))
-          (cond
-            ((or (= head "reduce") (= head "red"))
-              (let ((r (mau/creduce m t))) {:cmd "reduce" :sort (mau/term-sort m r) :result (mau/term->maude m r)}))
-            ((or (= head "rewrite") (= head "rew"))
-              (let ((r (mau/rewrite m t))) {:cmd "rewrite" :sort (mau/term-sort m r) :result (mau/term->maude m r)}))
-            (else {:cmd head :result "?"})))))))
-
-(define
-  mau/run-commands
-  (fn
-    (m stmts)
-    (if
-      (empty? stmts)
-      (list)
-      (if
-        (empty? (first stmts))
-        (mau/run-commands m (rest stmts))
-        (cons
-          (mau/run-command m (first stmts))
-          (mau/run-commands m (rest stmts)))))))
-
-(define
-  mau/run-program
-  (fn
-    (src)
-    (let
-      ((toks (mau/tokenize src)))
-      (let
-        ((eidx (mau/module-end-idx toks 0)))
-        (let
-          ((m (mau/parse-module-from-toks (mau/take toks (+ eidx 1))))
-            (cmd-toks (mau/drop toks (+ eidx 1))))
-          (mau/run-commands m (mau/split-statements cmd-toks)))))))
-
-;; just the rendered result strings
-(define
-  mau/run
-  (fn (src) (map (fn (r) (get r :result)) (mau/run-program src))))
-
-;; Maude-style printout: `result SORT: TERM` for reduce/rewrite, the path for search
-(define
-  mau/run-pretty
-  (fn
-    (src)
-    (map
-      (fn
-        (r)
-        (if
-          (= (get r :cmd) "search")
-          (str "search: " (get r :result))
-          (str "result " (get r :sort) ": " (get r :result))))
-      (mau/run-program src))))

lib/maude/scoreboard.json

@@ -1,24 +0,0 @@
-{
-  "lang": "maude",
-  "total_passed": 274,
-  "total_failed": 0,
-  "total": 274,
-  "suites": [
-    {"name":"parse","passed":65,"failed":0,"total":65},
-    {"name":"reduce","passed":26,"failed":0,"total":26},
-    {"name":"matching","passed":28,"failed":0,"total":28},
-    {"name":"confluence","passed":12,"failed":0,"total":12},
-    {"name":"conditional","passed":19,"failed":0,"total":19},
-    {"name":"owise","passed":8,"failed":0,"total":8},
-    {"name":"gather","passed":7,"failed":0,"total":7},
-    {"name":"sorts","passed":14,"failed":0,"total":14},
-    {"name":"rewrite","passed":21,"failed":0,"total":21},
-    {"name":"searchpath","passed":8,"failed":0,"total":8},
-    {"name":"strategy","passed":19,"failed":0,"total":19},
-    {"name":"meta","passed":18,"failed":0,"total":18},
-    {"name":"pretty","passed":11,"failed":0,"total":11},
-    {"name":"run","passed":10,"failed":0,"total":10},
-    {"name":"effects","passed":8,"failed":0,"total":8}
-  ],
-  "generated": "2026-06-07T20:18:07+00:00"
-}

lib/maude/scoreboard.md

@@ -1,21 +0,0 @@
-# maude scoreboard
-
-**274 / 274 passing** (0 failure(s)).
-
-| Suite | Passed | Total | Status |
-|-------|--------|-------|--------|
-| parse | 65 | 65 | ok |
-| reduce | 26 | 26 | ok |
-| matching | 28 | 28 | ok |
-| confluence | 12 | 12 | ok |
-| conditional | 19 | 19 | ok |
-| owise | 8 | 8 | ok |
-| gather | 7 | 7 | ok |
-| sorts | 14 | 14 | ok |
-| rewrite | 21 | 21 | ok |
-| searchpath | 8 | 8 | ok |
-| strategy | 19 | 19 | ok |
-| meta | 18 | 18 | ok |
-| pretty | 11 | 11 | ok |
-| run | 10 | 10 | ok |
-| effects | 8 | 8 | ok |

lib/maude/searchpath.sx

@@ -1,103 +0,0 @@
-;; lib/maude/searchpath.sx — reachability search returning the witness path.
-;;
-;; mau/search (rewrite.sx) answers yes/no. For puzzle solvers you want the
-;; actual sequence of states from start to goal. mau/search-path runs the same
-;; BFS but threads the path so far; it returns the list of canonical states
-;; start..goal (shortest by step count) or nil if unreachable within depth.
-
-(define mau/reverse2 (fn (xs) (mau/rev-acc xs (list))))
-
-(define
-  mau/rev-acc
-  (fn
-    (xs acc)
-    (if (empty? xs) acc (mau/rev-acc (rest xs) (cons (first xs) acc)))))
-
-;; find a frontier path whose current state (its head) matches the goal canon
-(define
-  mau/path-hit
-  (fn
-    (theory frontier goal)
-    (cond
-      ((empty? frontier) nil)
-      ((= (mau/canon theory (first (first frontier))) goal)
-        (first frontier))
-      (else (mau/path-hit theory (rest frontier) goal)))))
-
-(define
-  mau/bfs-path
-  (fn
-    (theory eqs rules frontier seen goal depth)
-    (let
-      ((hit (mau/path-hit theory frontier goal)))
-      (cond
-        ((not (= hit nil)) hit)
-        ((<= depth 0) nil)
-        ((empty? frontier) nil)
-        (else
-          (let
-            ((newf (list)) (newseen seen))
-            (for-each
-              (fn
-                (path)
-                (for-each
-                  (fn
-                    (succ)
-                    (let
-                      ((c (mau/canon theory succ)))
-                      (when
-                        (not (mau/member? c newseen))
-                        (do
-                          (set! newseen (cons c newseen))
-                          (append! newf (cons succ path))))))
-                  (mau/all-successors theory eqs rules (first path))))
-              frontier)
-            (mau/bfs-path
-              theory
-              eqs
-              rules
-              newf
-              newseen
-              goal
-              (- depth 1))))))))
-
-;; term-level: returns the canonical-state path start..goal, or nil
-(define
-  mau/search-path-terms
-  (fn
-    (m start-term goal-term max-depth)
-    (let
-      ((theory (mau/build-theory m))
-        (eqs (mau/module-eqs m))
-        (rules (mau/module-rules m)))
-      (let
-        ((start (mau/cnormalize theory eqs start-term mau/reduce-fuel))
-          (goal
-            (mau/canon
-              theory
-              (mau/cnormalize theory eqs goal-term mau/reduce-fuel))))
-        (let
-          ((res (mau/bfs-path theory eqs rules (list (list start)) (list (mau/canon theory start)) goal max-depth)))
-          (if
-            (= res nil)
-            nil
-            (map (fn (t) (mau/canon theory t)) (mau/reverse2 res))))))))
-
-(define
-  mau/search-path
-  (fn
-    (m start-src goal-src max-depth)
-    (mau/search-path-terms
-      m
-      (mau/parse-term-in m start-src)
-      (mau/parse-term-in m goal-src)
-      max-depth)))
-
-;; number of steps in the shortest solution (nil if unreachable)
-(define
-  mau/search-length
-  (fn
-    (m start-src goal-src max-depth)
-    (let
-      ((p (mau/search-path m start-src goal-src max-depth)))
-      (if (= p nil) nil (- (len p) 1)))))

lib/maude/sorts.sx

@@ -1,87 +0,0 @@
-;; lib/maude/sorts.sx — order-sorted least-sort inference.
-;;
-;; Order-sorted signatures: subsorts induce a partial order on sorts, and an
-;; overloaded operator can have several declarations. The LEAST SORT of a term
-;; is the smallest result sort among the operator declarations whose argument
-;; sorts the actual arguments satisfy (modulo subsorting). This is what lets
-;; `f(1)` be a NzNat while `f(s 0)` is only a Nat when f is declared at both.
-;;
-;;   mau/term-sort   M T        -> least sort of T (string, "?" if unknown)
-;;   mau/has-sort?   M T SORT   -> does T's least sort fit under SORT?
-
-(define
-  mau/arg-sorts-ok?
-  (fn
-    (m argsorts declared)
-    (cond
-      ((and (empty? argsorts) (empty? declared)) true)
-      ((or (empty? argsorts) (empty? declared)) false)
-      ((mau/sort<=? m (first argsorts) (first declared))
-        (mau/arg-sorts-ok? m (rest argsorts) (rest declared)))
-      (else false))))
-
-(define
-  mau/matching-ops
-  (fn
-    (m name argsorts)
-    (filter
-      (fn
-        (op)
-        (and
-          (= (len (get op :arity)) (len argsorts))
-          (mau/arg-sorts-ok? m argsorts (get op :arity))))
-      (mau/ops-named m name))))
-
-(define
-  mau/least-loop
-  (fn
-    (m best rst)
-    (cond
-      ((empty? rst) best)
-      ((mau/sort<=? m (first rst) best)
-        (mau/least-loop m (first rst) (rest rst)))
-      (else (mau/least-loop m best (rest rst))))))
-
-(define
-  mau/least-sort
-  (fn
-    (m sorts)
-    (if (empty? sorts) "?" (mau/least-loop m (first sorts) (rest sorts)))))
-
-(define
-  mau/result-sort
-  (fn
-    (m name argsorts)
-    (let
-      ((cands (mau/matching-ops m name argsorts)))
-      (if
-        (empty? cands)
-        (let
-          ((any (mau/ops-named m name)))
-          (if (empty? any) "?" (get (first any) :result)))
-        (mau/least-sort m (map (fn (op) (get op :result)) cands))))))
-
-(define
-  mau/term-sort
-  (fn
-    (m t)
-    (cond
-      ((mau/var? t) (mau/vsort t))
-      ((mau/app? t)
-        (mau/result-sort
-          m
-          (mau/op t)
-          (map (fn (a) (mau/term-sort m a)) (mau/args t))))
-      (else "?"))))
-
-(define
-  mau/term-sort-src
-  (fn (m src) (mau/term-sort m (mau/parse-term-in m src))))
-
-(define
-  mau/has-sort?
-  (fn (m t sort) (mau/sort<=? m (mau/term-sort m t) sort)))
-
-(define
-  mau/has-sort-src?
-  (fn (m src sort) (mau/has-sort? m (mau/parse-term-in m src) sort)))

lib/maude/strategy.sx

@@ -1,217 +0,0 @@
-;; lib/maude/strategy.sx — strategy language (Phase 6).
-;;
-;; A strategy controls HOW rules are applied. Strategies are first-class values
-;; (tagged dicts) and SET-VALUED: applying a strategy to a term yields the set
-;; (deduped by canonical form) of result terms. The same rule set under
-;; different strategies computes different things — `;` sequences, `|` unions,
-;; `*`/`+` iterate, `!` normalises.
-;;
-;; Constructors:
-;;   (mau/s-idle)            identity (the term itself)
-;;   (mau/s-fail)            empty set
-;;   (mau/s-all)             apply any rule once, anywhere
-;;   (mau/s-rule LABEL)      apply a named rule once, anywhere
-;;   (mau/s-seq A B)         A ; B   (apply B to every result of A)
-;;   (mau/s-alt A B)         A | B   (union of results)
-;;   (mau/s-star A)          A *     (reflexive-transitive closure)
-;;   (mau/s-plus A)          A +     (one or more)
-;;   (mau/s-bang A)          A !     (normal forms: results where A can't apply)
-;;   (mau/s-name N)          look up named strategy N in the env
-;;
-;; Run with (mau/srun M STRATS STRAT SRC): STRATS is a dict NAME -> strategy.
-
-(define mau/s-idle (fn () {:s :idle}))
-(define mau/s-fail (fn () {:s :fail}))
-(define mau/s-all (fn () {:s :all}))
-(define mau/s-rule (fn (label) {:label label :s :rule}))
-(define mau/s-seq (fn (a b) {:a a :b b :s :seq}))
-(define mau/s-alt (fn (a b) {:a a :b b :s :alt}))
-(define mau/s-star (fn (a) {:a a :s :star}))
-(define mau/s-plus (fn (a) {:a a :s :plus}))
-(define mau/s-bang (fn (a) {:a a :s :bang}))
-(define mau/s-name (fn (n) {:n n :s :name}))
-
-(define
-  mau/rules-with-label
-  (fn (rules label) (filter (fn (r) (= (get r :label) label)) rules)))
-
-(define
-  mau/dedup-loop
-  (fn
-    (theory ts seen acc)
-    (if
-      (empty? ts)
-      acc
-      (let
-        ((c (mau/canon theory (first ts))))
-        (if
-          (mau/member? c seen)
-          (mau/dedup-loop theory (rest ts) seen acc)
-          (mau/dedup-loop
-            theory
-            (rest ts)
-            (cons c seen)
-            (mau/append2 acc (list (first ts)))))))))
-
-(define
-  mau/dedup-canon
-  (fn (theory ts) (mau/dedup-loop theory ts (list) (list))))
-
-;; ---- strategy interpreter ----
-
-(define
-  mau/sapply
-  (fn
-    (ctx strat term)
-    (let
-      ((k (get strat :s)) (theory (get ctx :theory)))
-      (cond
-        ((= k "idle") (list term))
-        ((= k "fail") (list))
-        ((= k "all")
-          (mau/dedup-canon
-            theory
-            (mau/all-successors theory (get ctx :eqs) (get ctx :rules) term)))
-        ((= k "rule")
-          (mau/dedup-canon
-            theory
-            (mau/all-successors
-              theory
-              (get ctx :eqs)
-              (mau/rules-with-label (get ctx :rules) (get strat :label))
-              term)))
-        ((= k "seq")
-          (mau/dedup-canon
-            theory
-            (mau/concat-map
-              (fn (t) (mau/sapply ctx (get strat :b) t))
-              (mau/sapply ctx (get strat :a) term))))
-        ((= k "alt")
-          (mau/dedup-canon
-            theory
-            (mau/append2
-              (mau/sapply ctx (get strat :a) term)
-              (mau/sapply ctx (get strat :b) term))))
-        ((= k "star") (mau/sstar ctx (get strat :a) term))
-        ((= k "plus")
-          (mau/dedup-canon
-            theory
-            (mau/concat-map
-              (fn (t) (mau/sstar ctx (get strat :a) t))
-              (mau/sapply ctx (get strat :a) term))))
-        ((= k "bang")
-          (mau/dedup-canon theory (mau/sbang ctx (get strat :a) term)))
-        ((= k "name")
-          (mau/sapply ctx (get (get ctx :strats) (get strat :n)) term))
-        (else (list))))))
-
-;; reflexive-transitive closure: term plus everything reachable via A
-(define
-  mau/sstar
-  (fn
-    (ctx a term)
-    (mau/sstar-loop
-      ctx
-      a
-      (list term)
-      (list (mau/canon (get ctx :theory) term))
-      (list term))))
-
-(define
-  mau/sstar-loop
-  (fn
-    (ctx a frontier seen acc)
-    (if
-      (empty? frontier)
-      acc
-      (let
-        ((newf (list))
-          (newseen seen)
-          (newacc acc)
-          (theory (get ctx :theory)))
-        (for-each
-          (fn
-            (t)
-            (for-each
-              (fn
-                (succ)
-                (let
-                  ((c (mau/canon theory succ)))
-                  (when
-                    (not (mau/member? c newseen))
-                    (do
-                      (set! newseen (cons c newseen))
-                      (append! newf succ)
-                      (append! newacc succ)))))
-              (mau/sapply ctx a t)))
-          frontier)
-        (mau/sstar-loop ctx a newf newseen newacc)))))
-
-;; normal forms: terms reachable via A where A yields nothing more
-(define
-  mau/sbang
-  (fn
-    (ctx a term)
-    (mau/sbang-loop
-      ctx
-      a
-      (list term)
-      (list (mau/canon (get ctx :theory) term))
-      (list))))
-
-(define
-  mau/sbang-loop
-  (fn
-    (ctx a frontier seen acc)
-    (if
-      (empty? frontier)
-      acc
-      (let
-        ((newf (list))
-          (newseen seen)
-          (newacc acc)
-          (theory (get ctx :theory)))
-        (for-each
-          (fn
-            (t)
-            (let
-              ((succs (mau/sapply ctx a t)))
-              (if
-                (empty? succs)
-                (append! newacc t)
-                (for-each
-                  (fn
-                    (succ)
-                    (let
-                      ((c (mau/canon theory succ)))
-                      (when
-                        (not (mau/member? c newseen))
-                        (do
-                          (set! newseen (cons c newseen))
-                          (append! newf succ)))))
-                  succs))))
-          frontier)
-        (mau/sbang-loop ctx a newf newseen newacc)))))
-
-;; ---- public API ----
-
-(define mau/make-sctx (fn (m strats) {:eqs (mau/module-eqs m) :theory (mau/build-theory m) :strats strats :rules (mau/module-rules m)}))
-
-(define
-  mau/srun
-  (fn
-    (m strats strat src)
-    (let
-      ((ctx (mau/make-sctx m strats)))
-      (let
-        ((t0 (mau/cnormalize (get ctx :theory) (get ctx :eqs) (mau/parse-term-in m src) mau/reduce-fuel)))
-        (mau/dedup-canon (get ctx :theory) (mau/sapply ctx strat t0))))))
-
-(define
-  mau/srun-canon
-  (fn
-    (m strats strat src)
-    (let
-      ((theory (mau/build-theory m)))
-      (mau/sort-strings
-        (map (fn (t) (mau/canon theory t)) (mau/srun m strats strat src))))))

lib/maude/term.sx

@@ -1,114 +0,0 @@
-;; lib/maude/term.sx — Maude term representation.
-;;
-;; A term is one of:
-;;   variable     {:t :var :name "X" :sort "Nat"}
-;;   application  {:t :app :op "_+_" :args (a b ...)}   (constant: empty args)
-;;
-;; Sorts attach to variables; operator/result sorts live on op declarations
-;; in the module signature, not on the term node. Overloading is resolved at
-;; reduction time, so the parser only records the operator name.
-
-(define mau/var (fn (name sort) {:name name :t :var :sort sort}))
-
-(define mau/app (fn (op args) {:op op :t :app :args args}))
-
-(define mau/const (fn (op) {:op op :t :app :args (list)}))
-
-(define mau/var? (fn (t) (and (dict? t) (= (get t :t) "var"))))
-
-(define mau/app? (fn (t) (and (dict? t) (= (get t :t) "app"))))
-
-(define mau/term? (fn (t) (or (mau/var? t) (mau/app? t))))
-
-(define mau/op (fn (t) (get t :op)))
-(define mau/args (fn (t) (get t :args)))
-(define mau/vname (fn (t) (get t :name)))
-(define mau/vsort (fn (t) (get t :sort)))
-(define mau/arity (fn (t) (len (get t :args))))
-
-(define mau/const? (fn (t) (and (mau/app? t) (empty? (mau/args t)))))
-
-(define
-  mau/args=?
-  (fn
-    (as bs)
-    (cond
-      ((and (empty? as) (empty? bs)) true)
-      ((or (empty? as) (empty? bs)) false)
-      (else
-        (and
-          (mau/term=? (first as) (first bs))
-          (mau/args=? (rest as) (rest bs)))))))
-
-(define
-  mau/term=?
-  (fn
-    (a b)
-    (cond
-      ((and (mau/var? a) (mau/var? b))
-        (and
-          (= (mau/vname a) (mau/vname b))
-          (= (mau/vsort a) (mau/vsort b))))
-      ((and (mau/app? a) (mau/app? b))
-        (and
-          (= (mau/op a) (mau/op b))
-          (mau/args=? (mau/args a) (mau/args b))))
-      (else false))))
-
-(define
-  mau/join-args
-  (fn
-    (args)
-    (cond
-      ((empty? args) "")
-      ((empty? (rest args)) (mau/term->str (first args)))
-      (else
-        (str (mau/term->str (first args)) ", " (mau/join-args (rest args)))))))
-
-(define
-  mau/term->str
-  (fn
-    (t)
-    (cond
-      ((mau/var? t) (mau/vname t))
-      ((mau/const? t) (mau/op t))
-      ((mau/app? t) (str (mau/op t) "(" (mau/join-args (mau/args t)) ")"))
-      (else "?"))))
-
-(define
-  mau/member?
-  (fn
-    (x xs)
-    (cond
-      ((empty? xs) false)
-      ((= x (first xs)) true)
-      (else (mau/member? x (rest xs))))))
-
-(define
-  mau/union
-  (fn
-    (xs ys)
-    (cond
-      ((empty? xs) ys)
-      ((mau/member? (first xs) ys) (mau/union (rest xs) ys))
-      (else (cons (first xs) (mau/union (rest xs) ys))))))
-
-(define
-  mau/term-vars
-  (fn
-    (t)
-    (cond
-      ((mau/var? t) (list (mau/vname t)))
-      ((mau/app? t) (mau/term-vars-list (mau/args t)))
-      (else (list)))))
-
-(define
-  mau/term-vars-list
-  (fn
-    (args)
-    (if
-      (empty? args)
-      (list)
-      (mau/union
-        (mau/term-vars (first args))
-        (mau/term-vars-list (rest args))))))

lib/maude/tests/conditional.sx

@@ -1,108 +0,0 @@
-;; lib/maude/tests/conditional.sx — Phase 4: conditional equations.
-
-(define mct-pass 0)
-(define mct-fail 0)
-(define mct-failures (list))
-
-(define
-  mct-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mct-pass (+ mct-pass 1))
-      (do
-        (set! mct-fail (+ mct-fail 1))
-        (append!
-          mct-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-;; ---- gcd (equational guard, recursive) ----
-
-(define
-  mct-gcd
-  (mau/parse-module
-    "fmod GCD is\n  sorts Nat Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _>_ : Nat Nat -> Bool .\n  op _-_ : Nat Nat -> Nat .\n  op gcd : Nat Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 > Y = false .\n  eq s X > 0 = true .\n  eq s X > s Y = X > Y .\n  eq X - 0 = X .\n  eq 0 - Y = 0 .\n  eq s X - s Y = X - Y .\n  eq gcd(X, 0) = X .\n  eq gcd(0, Y) = Y .\n  eq gcd(X, X) = X .\n  ceq gcd(X, Y) = gcd(X - Y, Y) if X > Y = true .\n  ceq gcd(X, Y) = gcd(Y, X) if Y > X = true .\nendfm"))
-
-(mct-check!
-  "gcd-6-4"
-  (mau/creduce->str mct-gcd "gcd(s s s s s s 0, s s s s 0)")
-  "s_(s_(0))")
-(mct-check!
-  "gcd-3-6"
-  (mau/creduce->str mct-gcd "gcd(s s s 0, s s s s s s 0)")
-  "s_(s_(s_(0)))")
-(mct-check!
-  "gcd-base-zero"
-  (mau/creduce->str mct-gcd "gcd(s s 0, 0)")
-  "s_(s_(0))")
-(mct-check!
-  "gcd-equal"
-  (mau/creduce->str mct-gcd "gcd(s s 0, s s 0)")
-  "s_(s_(0))")
-(mct-check!
-  "gcd-coprime"
-  (mau/creduce->str mct-gcd "gcd(s s s 0, s s 0)")
-  "s_(0)")
-;; guard predicate reductions
-(mct-check! "gt-true" (mau/creduce->str mct-gcd "s s 0 > s 0") "true")
-(mct-check! "gt-false" (mau/creduce->str mct-gcd "s 0 > s s 0") "false")
-
-;; ---- insertion sort (true/false guards) ----
-
-(define
-  mct-sort
-  (mau/parse-module
-    "fmod SORT is\n  sorts Nat List Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _<=_ : Nat Nat -> Bool .\n  op nil : -> List .\n  op _:_ : Nat List -> List .\n  op insert : Nat List -> List .\n  op sort : List -> List .\n  vars M N : Nat .\n  var L : List .\n  eq 0 <= N = true .\n  eq s M <= 0 = false .\n  eq s M <= s N = M <= N .\n  eq insert(N, nil) = N : nil .\n  ceq insert(N, M : L) = N : (M : L) if N <= M = true .\n  ceq insert(N, M : L) = M : insert(N, L) if N <= M = false .\n  eq sort(nil) = nil .\n  eq sort(N : L) = insert(N, sort(L)) .\nendfm"))
-
-(mct-check!
-  "sort-321"
-  (mau/creduce->str mct-sort "sort(s s s 0 : (s 0 : (s s 0 : nil)))")
-  "_:_(s_(0), _:_(s_(s_(0)), _:_(s_(s_(s_(0))), nil)))")
-(mct-check! "sort-empty" (mau/creduce->str mct-sort "sort(nil)") "nil")
-(mct-check!
-  "sort-singleton"
-  (mau/creduce->str mct-sort "sort(s s 0 : nil)")
-  "_:_(s_(s_(0)), nil)")
-(mct-check!
-  "insert-front"
-  (mau/creduce->str mct-sort "insert(0, s 0 : (s s 0 : nil))")
-  "_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
-(mct-check!
-  "insert-back"
-  (mau/creduce->str mct-sort "insert(s s s 0, s 0 : (s s 0 : nil))")
-  "_:_(s_(0), _:_(s_(s_(0)), _:_(s_(s_(s_(0))), nil)))")
-
-;; ---- max (conditional simplification, both branches) ----
-
-(define
-  mct-max
-  (mau/parse-module
-    "fmod MAX is\n  sorts Nat Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _<=_ : Nat Nat -> Bool .\n  op max : Nat Nat -> Nat .\n  vars M N : Nat .\n  eq 0 <= N = true .\n  eq s M <= 0 = false .\n  eq s M <= s N = M <= N .\n  ceq max(M, N) = M if N <= M = true .\n  ceq max(M, N) = N if N <= M = false .\nendfm"))
-
-(mct-check!
-  "max-left"
-  (mau/creduce->str mct-max "max(s s s 0, s 0)")
-  "s_(s_(s_(0)))")
-(mct-check!
-  "max-right"
-  (mau/creduce->str mct-max "max(s 0, s s 0)")
-  "s_(s_(0))")
-(mct-check!
-  "max-equal"
-  (mau/creduce->str mct-max "max(s s 0, s s 0)")
-  "s_(s_(0))")
-
-;; ---- boolean-kind condition (`if pred`) ----
-
-(define
-  mct-even
-  (mau/parse-module
-    "fmod EVEN is\n  sorts Nat Bool Tag .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op even : Nat -> Bool .\n  op evn : -> Tag .\n  op odd : -> Tag .\n  op tag : Nat -> Tag .\n  var N : Nat .\n  eq even(0) = true .\n  eq even(s 0) = false .\n  eq even(s s N) = even(N) .\n  ceq tag(N) = evn if even(N) .\n  ceq tag(N) = odd if even(N) = false .\nendfm"))
-
-(mct-check! "even-4" (mau/creduce->str mct-even "even(s s s s 0)") "true")
-(mct-check! "even-3" (mau/creduce->str mct-even "even(s s s 0)") "false")
-(mct-check! "tag-even-bool" (mau/creduce->str mct-even "tag(s s 0)") "evn")
-(mct-check! "tag-odd" (mau/creduce->str mct-even "tag(s s s 0)") "odd")
-
-(define mau-conditional-tests-run! (fn () {:failures mct-failures :total (+ mct-pass mct-fail) :passed mct-pass :failed mct-fail}))

lib/maude/tests/confluence.sx

@@ -1,101 +0,0 @@
-;; lib/maude/tests/confluence.sx — critical-pair / local-confluence checking.
-
-(define mcf-pass 0)
-(define mcf-fail 0)
-(define mcf-failures (list))
-
-(define
-  mcf-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mcf-pass (+ mcf-pass 1))
-      (do
-        (set! mcf-fail (+ mcf-fail 1))
-        (append!
-          mcf-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-;; peano addition: no LHS overlaps -> confluent
-(define
-  mcf-peano
-  (mau/parse-module
-    "fmod P is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\nendfm"))
-
-(mcf-check! "peano-confluent" (mau/confluent? mcf-peano) true)
-(mcf-check!
-  "peano-no-bad-pairs"
-  (len (mau/non-joinable-pairs mcf-peano))
-  0)
-
-;; f(a)=b, a=c : the inner `a` overlaps -> critical pair b vs f(c), NOT joinable
-(define
-  mcf-bad
-  (mau/parse-module
-    "fmod B is\n  sort T .\n  op a : -> T .\n  op b : -> T .\n  op c : -> T .\n  op f : T -> T .\n  eq f(a) = b .\n  eq a = c .\nendfm"))
-
-(mcf-check! "bad-not-confluent" (mau/confluent? mcf-bad) false)
-(mcf-check! "bad-one-pair" (len (mau/non-joinable-pairs mcf-bad)) 1)
-(mcf-check!
-  "bad-pair-shape"
-  (mau/cp->str mcf-bad (first (mau/non-joinable-pairs mcf-bad)))
-  "b <?> f(c)")
-(mcf-check!
-  "bad-has-cps"
-  (> (len (mau/critical-pairs mcf-bad)) 0)
-  true)
-
-;; adding f(c)=b joins the pair -> confluent
-(define
-  mcf-fixed
-  (mau/parse-module
-    "fmod F is\n  sort T .\n  op a : -> T .\n  op b : -> T .\n  op c : -> T .\n  op f : T -> T .\n  eq f(a) = b .\n  eq a = c .\n  eq f(c) = b .\nendfm"))
-
-(mcf-check! "fixed-confluent" (mau/confluent? mcf-fixed) true)
-
-;; self-overlap that is joinable: idempotent d(d(X)) = d(X)
-(define
-  mcf-idem
-  (mau/parse-module
-    "fmod I is\n  sort T .\n  op d : T -> T .\n  op x : -> T .\n  var X : T .\n  eq d(d(X)) = d(X) .\nendfm"))
-
-(mcf-check! "idem-confluent" (mau/confluent? mcf-idem) true)
-
-;; a free-op overlap that joins: g(h(X)) over h(a)
-(define
-  mcf-join
-  (mau/parse-module
-    "fmod J is\n  sort T .\n  op a : -> T .\n  op k : -> T .\n  op h : T -> T .\n  op g : T -> T .\n  op r : T -> T .\n  var X : T .\n  eq g(h(X)) = r(X) .\n  eq h(a) = k .\nendfm"))
-
-;; g(h(a)) -> r(a) (rule1) or g(k) (rule2 inside). Not joinable unless g(k) reduces.
-(mcf-check! "join-not-confluent" (mau/confluent? mcf-join) false)
-
-;; AC operator, genuinely confluent; joinability uses canonical form
-(define
-  mcf-ac
-  (mau/parse-module
-    "fmod AC is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  eq a + a = b .\nendfm"))
-
-(mcf-check! "ac-confluent" (mau/confluent? mcf-ac) true)
-
-;; unifier sanity (two-sided): f(X, b) unifies with f(a, Y)
-(mcf-check!
-  "unify-twosided"
-  (=
-    nil
-    (mau/u-unify
-      (mau/app "f" (list (mau/var "X" "T") (mau/const "b")))
-      (mau/app "f" (list (mau/const "a") (mau/var "Y" "T")))
-      {}))
-  false)
-;; occurs check: X vs f(X) fails
-(mcf-check!
-  "unify-occurs"
-  (mau/u-unify
-    (mau/var "X" "T")
-    (mau/app "f" (list (mau/var "X" "T")))
-    {})
-  nil)
-
-(define mau-confluence-tests-run! (fn () {:failures mcf-failures :total (+ mcf-pass mcf-fail) :passed mcf-pass :failed mcf-fail}))

lib/maude/tests/effects.sx

@@ -1,79 +0,0 @@
-;; lib/maude/tests/effects.sx — artdag-on-sx fit prototype.
-;;
-;; Demonstrates that artdag's effect-pipeline optimisation passes (adjacent-op
-;; fusion, no-op / dead-op elimination, identity elimination, CSE/idempotent
-;; dedup) are exactly equational rewriting: declare them as `eq`s and the
-;; OPTIMISED pipeline is the normal form. Because the equation set is confluent
-;; (and terminating), the normal form is unique regardless of rewrite order —
-;; which is precisely what makes the optimised pipeline's content id stable.
-;;
-;; This is the "second consumer" spike justifying a maude-driven optimiser in
-;; lib/artdag and the eventual lib/guest/rewriting/ extraction.
-
-(define mef-pass 0)
-(define mef-fail 0)
-(define mef-failures (list))
-
-(define
-  mef-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mef-pass (+ mef-pass 1))
-      (do
-        (set! mef-fail (+ mef-fail 1))
-        (append!
-          mef-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-(define
-  mef-m
-  (mau/parse-module
-    "fmod EFFECTS is\n  sorts Img Num .\n  op src : -> Img .\n  op 0 : -> Num .\n  op s_ : Num -> Num .\n  op _+_ : Num Num -> Num .\n  op blur : Img Num -> Img .\n  op bright : Img Num -> Img .\n  op id : Img -> Img .\n  op over : Img Img -> Img [comm] .\n  vars I J : Img .\n  vars M N : Num .\n  eq 0 + N = N .\n  eq s M + N = s (M + N) .\n  eq id(I) = I .\n  eq blur(I, 0) = I .\n  eq bright(I, 0) = I .\n  eq blur(blur(I, M), N) = blur(I, M + N) .\n  eq bright(bright(I, M), N) = bright(I, M + N) .\n  eq over(I, I) = I .\nendfm"))
-
-;; adjacent-op fusion: two blurs collapse, radii add
-(mef-check!
-  "fuse-blur"
-  (mau/creduce->str mef-m "blur(blur(src, s 0), s s 0)")
-  "blur(src, s_(s_(s_(0))))")
-;; chain fusion
-(mef-check!
-  "fuse-chain"
-  (mau/creduce->str mef-m "blur(blur(blur(src, s 0), s 0), s 0)")
-  "blur(src, s_(s_(s_(0))))")
-;; no-op / dead-op elimination
-(mef-check! "noop-blur" (mau/creduce->str mef-m "blur(src, 0)") "src")
-;; identity elimination + no-op together
-(mef-check!
-  "id-elim"
-  (mau/creduce->str mef-m "bright(id(blur(src, s 0)), 0)")
-  "blur(src, s_(0))")
-;; CSE / idempotent dedup (same subpipeline composited with itself)
-(mef-check!
-  "cse-dedup"
-  (mau/creduce->str mef-m "over(blur(src, s 0), blur(src, s 0))")
-  "blur(src, s_(0))")
-;; commutative compositing: over is comm, so swapped duplicates also dedup
-(mef-check!
-  "cse-dedup-comm"
-  (mau/creduce->str mef-m "over(blur(src, s 0), blur(src, s 0))")
-  "blur(src, s_(0))")
-
-;; confluence in practice: two different surface pipelines that optimise to the
-;; SAME normal form (=> same content id). bright-fused twice vs once-by-3.
-(mef-check!
-  "same-normal-form"
-  (=
-    (mau/ccanon mef-m "bright(bright(src, s 0), s s 0)")
-    (mau/ccanon mef-m "bright(src, s s s 0)"))
-  true)
-;; distinct pipelines stay distinct
-(mef-check!
-  "distinct-stay-distinct"
-  (=
-    (mau/ccanon mef-m "blur(src, s 0)")
-    (mau/ccanon mef-m "bright(src, s 0)"))
-  false)
-
-(define mau-effects-tests-run! (fn () {:failures mef-failures :total (+ mef-pass mef-fail) :passed mef-pass :failed mef-fail}))

lib/maude/tests/gather.sx

@@ -1,66 +0,0 @@
-;; lib/maude/tests/gather.sx — gather / parse-time associativity.
-
-(define mga-pass 0)
-(define mga-fail 0)
-(define mga-failures (list))
-
-(define
-  mga-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mga-pass (+ mga-pass 1))
-      (do
-        (set! mga-fail (+ mga-fail 1))
-        (append!
-          mga-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-(define
-  mga-m
-  (mau/parse-module
-    "fmod L is\n  sorts Nat List .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op nil : -> List .\n  op _:_ : Nat List -> List [gather (e E)] .\n  op _+_ : Nat Nat -> Nat .\n  op _-_ : Nat Nat -> Nat [gather (E e)] .\n  vars X Y : Nat .\nendfm"))
-
-;; cons is right-associative: a : b : c  ==  a : (b : c)
-(mga-check!
-  "cons-right"
-  (mau/term->str (mau/parse-term-in mga-m "0 : s 0 : nil"))
-  "_:_(0, _:_(s_(0), nil))")
-;; + has no gather -> default left-assoc
-(mga-check!
-  "plus-left"
-  (mau/term->str (mau/parse-term-in mga-m "X + Y + X"))
-  "_+_(_+_(X, Y), X)")
-;; explicit (E e) is left
-(mga-check!
-  "minus-left"
-  (mau/term->str (mau/parse-term-in mga-m "X - Y - X"))
-  "_-_(_-_(X, Y), X)")
-;; gather attr recorded
-(mga-check!
-  "gather-recorded"
-  (get (get (first (mau/ops-named mga-m "_:_")) :attrs) :gather)
-  (list "e" "E"))
-
-;; ---- full insertion sort over BARE cons lists (no parens needed) ----
-
-(define
-  mga-sort
-  (mau/parse-module
-    "fmod SORT is\n  sorts Nat List Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _<=_ : Nat Nat -> Bool .\n  op nil : -> List .\n  op _:_ : Nat List -> List [gather (e E)] .\n  op insert : Nat List -> List .\n  op sort : List -> List .\n  vars M N : Nat .\n  var L : List .\n  eq 0 <= N = true .\n  eq s M <= 0 = false .\n  eq s M <= s N = M <= N .\n  eq insert(N, nil) = N : nil .\n  ceq insert(N, M : L) = N : M : L if N <= M = true .\n  ceq insert(N, M : L) = M : insert(N, L) if N <= M = false .\n  eq sort(nil) = nil .\n  eq sort(N : L) = insert(N, sort(L)) .\nendfm"))
-
-(mga-check!
-  "sort-bare"
-  (mau/creduce->str mga-sort "sort(s s s 0 : s 0 : s s 0 : nil)")
-  "_:_(s_(0), _:_(s_(s_(0)), _:_(s_(s_(s_(0))), nil)))")
-(mga-check!
-  "sort-bare-5"
-  (mau/creduce->str mga-sort "sort(s s 0 : 0 : s 0 : nil)")
-  "_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
-(mga-check!
-  "insert-bare"
-  (mau/creduce->str mga-sort "insert(s 0, 0 : s s 0 : nil)")
-  "_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
-
-(define mau-gather-tests-run! (fn () {:failures mga-failures :total (+ mga-pass mga-fail) :passed mga-pass :failed mga-fail}))

lib/maude/tests/matching.sx

@@ -1,170 +0,0 @@
-;; lib/maude/tests/matching.sx — Phase 3: matching modulo assoc/comm/id.
-
-(define mmt-pass 0)
-(define mmt-fail 0)
-(define mmt-failures (list))
-
-(define
-  mmt-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mmt-pass (+ mmt-pass 1))
-      (do
-        (set! mmt-fail (+ mmt-fail 1))
-        (append!
-          mmt-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-;; ---- multi-valued matching enumeration ----
-
-(define
-  mmt-acg
-  (mau/parse-module
-    "fmod ACG is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op c : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  op _._ : S S -> S [assoc] .\n  vars X Y : S .\nendfm"))
-
-;; X + Y against a + b + c (AC, no id): 6 solutions (each non-empty 2-split).
-(mmt-check!
-  "ac-match-count"
-  (len
-    (mau/match-all
-      mmt-acg
-      (mau/parse-term-in mmt-acg "X + Y")
-      (mau/parse-term-in mmt-acg "a + b + c")))
-  6)
-;; X + a against a + b + c: X must be b + c (one solution, multiset).
-(mmt-check!
-  "ac-match-partial"
-  (len
-    (mau/match-all
-      mmt-acg
-      (mau/parse-term-in mmt-acg "X + a")
-      (mau/parse-term-in mmt-acg "a + b + c")))
-  1)
-;; assoc-only X . Y against a . b . c: ordered 2-splits -> 2 solutions.
-(mmt-check!
-  "assoc-match-count"
-  (len
-    (mau/match-all
-      mmt-acg
-      (mau/parse-term-in mmt-acg "X . Y")
-      (mau/parse-term-in mmt-acg "a . b . c")))
-  2)
-;; no match: a + a pattern against a + b
-(mmt-check!
-  "ac-no-match"
-  (len
-    (mau/match-all
-      mmt-acg
-      (mau/parse-term-in mmt-acg "a + a")
-      (mau/parse-term-in mmt-acg "a + b")))
-  0)
-
-;; ---- comm (non-assoc) matching ----
-
-(define
-  mmt-pair
-  (mau/parse-module
-    "fmod PAIR is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op p : S S -> S [comm] .\n  op fst : S -> S .\n  vars X Y : S .\n  eq fst(p(X, a)) = X .\nendfm"))
-
-(mmt-check!
-  "comm-both-orders"
-  (mau/ac-reduce->str mmt-pair "fst(p(b, a))")
-  "b")
-(mmt-check! "comm-swapped" (mau/ac-reduce->str mmt-pair "fst(p(a, b))") "b")
-
-;; ---- identity ----
-
-(define
-  mmt-id
-  (mau/parse-module
-    "fmod IDMOD is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op e : -> S .\n  op _*_ : S S -> S [assoc comm id: e] .\n  vars X Y : S .\nendfm"))
-
-(mmt-check! "id-drop" (mau/ac-canon mmt-id "a * e") "a")
-(mmt-check! "id-drop-mid" (mau/ac-canon mmt-id "a * e * b") "_*_(a,b)")
-(mmt-check! "id-only" (mau/ac-canon mmt-id "e * e") "e")
-;; with id, X * Y matching a (singleton) succeeds (one var empty)
-(mmt-check!
-  "id-match-singleton"
-  (>
-    (len
-      (mau/match-all
-        mmt-id
-        (mau/parse-term-in mmt-id "X * Y")
-        (mau/parse-term-in mmt-id "a")))
-    0)
-  true)
-
-;; ---- multiset / bag rewriting ----
-
-(define
-  mmt-bag
-  (mau/parse-module
-    "fmod BAG is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op c : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  eq a + a = a .\nendfm"))
-
-(mmt-check! "bag-collapse" (mau/ac-canon mmt-bag "a + b + a") "_+_(a,b)")
-(mmt-check! "bag-deep" (mau/ac-canon mmt-bag "a + a + a") "a")
-(mmt-check! "bag-reorder" (mau/ac-canon mmt-bag "c + a + b + a") "_+_(a,b,c)")
-(mmt-check!
-  "bag-flatten-assoc"
-  (mau/ac-canon mmt-bag "(a + b) + (a + c)")
-  "_+_(a,b,c)")
-
-;; ---- set theory: idempotent union with empty (identity) ----
-
-(define
-  mmt-set
-  (mau/parse-module
-    "fmod SET is\n  sort Set .\n  op empty : -> Set .\n  op a : -> Set .\n  op b : -> Set .\n  op c : -> Set .\n  op _U_ : Set Set -> Set [assoc comm id: empty] .\n  var X : Set .\n  eq X U X = X .\nendfm"))
-
-(mmt-check! "set-dedup" (mau/ac-canon mmt-set "a U b U a") "_U_(a,b)")
-(mmt-check! "set-triple" (mau/ac-canon mmt-set "a U a U a") "a")
-(mmt-check!
-  "set-union"
-  (mau/ac-canon mmt-set "a U b U c U a U b")
-  "_U_(a,b,c)")
-(mmt-check! "set-empty" (mau/ac-canon mmt-set "a U empty") "a")
-(mmt-check! "set-empty-only" (mau/ac-canon mmt-set "empty U empty") "empty")
-
-;; ---- group equations (assoc, non-comm, identity + inverse) ----
-
-(define
-  mmt-group
-  (mau/parse-module
-    "fmod GROUP is\n  sort G .\n  op e : -> G .\n  op a : -> G .\n  op b : -> G .\n  op _*_ : G G -> G [assoc] .\n  op i : G -> G .\n  var X : G .\n  eq e * X = X .\n  eq X * e = X .\n  eq i(X) * X = e .\n  eq X * i(X) = e .\n  eq i(e) = e .\n  eq i(i(X)) = X .\nendfm"))
-
-(mmt-check! "group-inverse" (mau/ac-canon mmt-group "i(a) * a") "e")
-(mmt-check! "group-cancel" (mau/ac-canon mmt-group "i(a) * a * b") "b")
-(mmt-check! "group-cancel-mid" (mau/ac-canon mmt-group "b * i(a) * a") "b")
-(mmt-check! "group-double-inv" (mau/ac-canon mmt-group "i(i(a))") "a")
-(mmt-check! "group-id-left" (mau/ac-canon mmt-group "e * a") "a")
-(mmt-check! "group-right-inv" (mau/ac-canon mmt-group "a * i(a) * b") "b")
-
-;; ---- AC equality (canonical form) ----
-
-(define mmt-th (mau/build-theory mmt-acg))
-
-(mmt-check!
-  "ac-equal-reorder"
-  (mau/ac-equal?
-    mmt-th
-    (mau/parse-term-in mmt-acg "a + b + c")
-    (mau/parse-term-in mmt-acg "c + a + b"))
-  true)
-(mmt-check!
-  "ac-equal-renest"
-  (mau/ac-equal?
-    mmt-th
-    (mau/parse-term-in mmt-acg "(a + b) + c")
-    (mau/parse-term-in mmt-acg "a + (b + c)"))
-  true)
-(mmt-check!
-  "ac-noncomm-order"
-  (mau/ac-equal?
-    mmt-th
-    (mau/parse-term-in mmt-acg "a . b")
-    (mau/parse-term-in mmt-acg "b . a"))
-  false)
-
-(define mau-matching-tests-run! (fn () {:failures mmt-failures :total (+ mmt-pass mmt-fail) :passed mmt-pass :failed mmt-fail}))

lib/maude/tests/meta.sx

@@ -1,144 +0,0 @@
-;; lib/maude/tests/meta.sx — Phase 7: reflection (META-LEVEL).
-
-(define mmtt-pass 0)
-(define mmtt-fail 0)
-(define mmtt-failures (list))
-
-(define
-  mmtt-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mmtt-pass (+ mmtt-pass 1))
-      (do
-        (set! mmtt-fail (+ mmtt-fail 1))
-        (append!
-          mmtt-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-(define
-  mmtt-peano
-  (mau/parse-module
-    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat [assoc comm] .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\nendfm"))
-
-(define
-  mmtt-ndet
-  (mau/parse-module
-    "mod NDET is\n  sort S .\n  ops a b c : -> S .\n  rl [r1] : a => b .\n  rl [r2] : b => c .\nendm"))
-
-;; ---- terms-as-data: up / down ----
-
-(mmtt-check!
-  "up-const"
-  (mau/term->str (mau/meta-up mmtt-peano "0"))
-  "mt-app(0)")
-(mmtt-check!
-  "up-s0"
-  (mau/term->str (mau/meta-up mmtt-peano "s 0"))
-  "mt-app(s_, mt-app(0))")
-(mmtt-check!
-  "up-var"
-  (mau/term->str (mau/up-term (mau/var "X" "Nat")))
-  "mt-var(X, Nat)")
-(mmtt-check!
-  "up-plus"
-  (mau/term->str (mau/meta-up mmtt-peano "s 0 + 0"))
-  "mt-app(_+_, mt-app(s_, mt-app(0)), mt-app(0))")
-
-;; round trip: down(up(t)) = t
-(mmtt-check!
-  "roundtrip-const"
-  (mau/term=?
-    (mau/down-term (mau/meta-up mmtt-peano "0"))
-    (mau/parse-term-in mmtt-peano "0"))
-  true)
-(mmtt-check!
-  "roundtrip-nested"
-  (mau/term=?
-    (mau/down-term (mau/meta-up mmtt-peano "s (s 0 + 0)"))
-    (mau/parse-term-in mmtt-peano "s (s 0 + 0)"))
-  true)
-(mmtt-check!
-  "roundtrip-var"
-  (mau/term=?
-    (mau/down-term (mau/up-term (mau/var "X" "Nat")))
-    (mau/var "X" "Nat"))
-  true)
-
-;; ---- reflective metaReduce ----
-
-(mmtt-check!
-  "meta-reduce"
-  (mau/term->str (mau/meta-reduce-src mmtt-peano "s 0 + s s 0"))
-  "s_(s_(s_(0)))")
-;; metaReduce returns a REPRESENTED result (a meta-term)
-(mmtt-check!
-  "meta-reduce-is-meta"
-  (=
-    (mau/op (mau/meta-reduce mmtt-peano (mau/meta-up mmtt-peano "s 0 + 0")))
-    "mt-app")
-  true)
-
-;; ---- meta-circular law: down(metaReduce(up t)) =AC= reduce t ----
-
-(mmtt-check!
-  "meta-circular-1"
-  (mau/meta-circular? mmtt-peano "s 0 + s s 0")
-  true)
-(mmtt-check!
-  "meta-circular-2"
-  (mau/meta-circular? mmtt-peano "s (s 0 + s 0)")
-  true)
-(mmtt-check!
-  "meta-reduce-eq-up"
-  (mau/term=?
-    (mau/meta-reduce mmtt-peano (mau/meta-up mmtt-peano "s 0 + s 0"))
-    (mau/up-term (mau/creduce-term mmtt-peano "s 0 + s 0")))
-  true)
-
-;; ---- metaApply: reflect a single rule step ----
-
-(mmtt-check!
-  "meta-apply-r1"
-  (mau/term=?
-    (mau/down-term
-      (mau/meta-apply mmtt-ndet "r1" (mau/meta-up mmtt-ndet "a")))
-    (mau/parse-term-in mmtt-ndet "b"))
-  true)
-(mmtt-check!
-  "meta-apply-fail"
-  (mau/meta-apply mmtt-ndet "r2" (mau/meta-up mmtt-ndet "a"))
-  nil)
-
-;; ---- generic theorem helper: equational proof by reduction ----
-
-;; commutativity instance: 1 + 2 and 2 + 1 reduce to the same normal form.
-(mmtt-check!
-  "prove-comm-instance"
-  (mau/meta-prove-equal? mmtt-peano "s 0 + s s 0" "s s 0 + s 0")
-  true)
-;; associativity instance
-(mmtt-check!
-  "prove-assoc-instance"
-  (mau/meta-prove-equal? mmtt-peano "(s 0 + s 0) + s 0" "s 0 + (s 0 + s 0)")
-  true)
-;; a non-theorem
-(mmtt-check!
-  "prove-false"
-  (mau/meta-prove-equal? mmtt-peano "s 0 + s 0" "s 0")
-  false)
-
-;; ---- build a program meta-level, then run it ----
-
-;; construct the meta-representation of s(s(0)) by hand, down it, reduce.
-(define
-  mmtt-built
-  (mau/up-term
-    (mau/app "s_" (list (mau/app "s_" (list (mau/const "0")))))))
-(mmtt-check!
-  "built-down-reduce"
-  (mau/term->str (mau/creduce mmtt-peano (mau/down-term mmtt-built)))
-  "s_(s_(0))")
-
-(define mau-meta-tests-run! (fn () {:failures mmtt-failures :total (+ mmtt-pass mmtt-fail) :passed mmtt-pass :failed mmtt-fail}))

lib/maude/tests/owise.sx

@@ -1,61 +0,0 @@
-;; lib/maude/tests/owise.sx — owise (otherwise) equations.
-
-(define mow-pass 0)
-(define mow-fail 0)
-(define mow-failures (list))
-
-(define
-  mow-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mow-pass (+ mow-pass 1))
-      (do
-        (set! mow-fail (+ mow-fail 1))
-        (append!
-          mow-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-;; The owise catch-all is declared FIRST, yet must only fire when no ordinary
-;; equation applies — proving owise is order-independent, not just last-match.
-(define
-  mow-lookup
-  (mau/parse-module
-    "fmod LOOKUP is\n  sorts Key Val .\n  ops k1 k2 k3 : -> Key .\n  ops v1 v2 none : -> Val .\n  op lookup : Key -> Val .\n  var K : Key .\n  eq lookup(K) = none [owise] .\n  eq lookup(k1) = v1 .\n  eq lookup(k2) = v2 .\nendfm"))
-
-(mow-check!
-  "owise-parsed"
-  (get (first (mau/module-eqs mow-lookup)) :owise)
-  true)
-(mow-check!
-  "ordinary-not-owise"
-  (get (nth (mau/module-eqs mow-lookup) 1) :owise)
-  false)
-
-(mow-check! "lookup-hit-1" (mau/creduce->str mow-lookup "lookup(k1)") "v1")
-(mow-check! "lookup-hit-2" (mau/creduce->str mow-lookup "lookup(k2)") "v2")
-(mow-check!
-  "lookup-default"
-  (mau/creduce->str mow-lookup "lookup(k3)")
-  "none")
-
-;; owise with a guard among the ordinary equations
-(define
-  mow-sign
-  (mau/parse-module
-    "fmod SIGN is\n  sorts Nat Sign Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _>_ : Nat Nat -> Bool .\n  op pos : -> Sign .\n  op zero : -> Sign .\n  op sign : Nat -> Sign .\n  var N : Nat .\n  eq 0 > N = false .\n  eq s N > 0 = true .\n  eq s N > s M = N > M .\n  eq sign(N) = pos [owise] .\n  eq sign(0) = zero .\n  vars M : Nat .\nendfm"))
-
-(mow-check! "sign-zero" (mau/creduce->str mow-sign "sign(0)") "zero")
-(mow-check! "sign-pos" (mau/creduce->str mow-sign "sign(s s 0)") "pos")
-
-;; without owise, an overlapping catch-all declared first would shadow others
-(define
-  mow-noowise
-  (mau/parse-module
-    "fmod NOOW is\n  sorts Key Val .\n  ops k1 k2 : -> Key .\n  ops v1 def : -> Val .\n  op f : Key -> Val .\n  var K : Key .\n  eq f(K) = def .\n  eq f(k1) = v1 .\nendfm"))
-
-;; here f(k1) hits the first (catch-all) equation -> def (no owise tag)
-(mow-check! "noowise-shadows" (mau/creduce->str mow-noowise "f(k1)") "def")
-
-(define mau-owise-tests-run! (fn () {:failures mow-failures :total (+ mow-pass mow-fail) :passed mow-pass :failed mow-fail}))

lib/maude/tests/parse.sx

@@ -1,250 +0,0 @@
-;; lib/maude/tests/parse.sx — Phase 1: tokenizer, signatures, term/eq parsing.
-
-(define mpt-pass 0)
-(define mpt-fail 0)
-(define mpt-failures (list))
-
-(define
-  mpt-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! mpt-pass (+ mpt-pass 1))
-      (do
-        (set! mpt-fail (+ mpt-fail 1))
-        (append!
-          mpt-failures
-          (str name "  expected: " expected "  got: " got))))))
-
-;; ---- modules under test ----
-
-(define
-  mpt-peano
-  (mau/parse-module
-    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat [assoc comm prec 33] .\n  op _*_ : Nat Nat -> Nat [assoc comm] .\n  vars X Y : Nat .\n  eq 0 + X = X .\n  eq s X + Y = s (X + Y) .\n  eq 0 * X = 0 .\nendfm"))
-
-(define
-  mpt-natlist
-  (mau/parse-module
-    "fmod NATLIST is\n  sorts Zero NzNat Nat List .\n  subsort Zero < Nat .\n  subsort NzNat < Nat .\n  subsort Nat < List .\n  op 0 : -> Zero .\n  op nil : -> List .\n  op _;_ : List List -> List [assoc id: nil] .\n  op head : List -> Nat .\n  op length : List -> Nat .\n  vars L M : List .\n  var N : Nat .\n  eq length(nil) = 0 .\n  eq head(N ; L) = N .\nendfm"))
-
-;; ---- tokenizer ----
-
-(define mpt-toks (mau/tokenize "op _+_ : Nat Nat -> Nat [assoc] ."))
-
-(mpt-check! "tok-count" (len mpt-toks) 11)
-(mpt-check! "tok-op" (nth mpt-toks 0) "op")
-(mpt-check! "tok-mixfix" (nth mpt-toks 1) "_+_")
-(mpt-check! "tok-colon" (nth mpt-toks 2) ":")
-(mpt-check! "tok-arrow" (nth mpt-toks 5) "->")
-(mpt-check! "tok-lbrack" (nth mpt-toks 7) "[")
-(mpt-check! "tok-dot" (nth mpt-toks 10) ".")
-(mpt-check!
-  "tok-comment"
-  (len (mau/tokenize "sort Nat . --- a comment\nop 0 : -> Nat ."))
-  9)
-
-;; ---- mixfix classification ----
-
-(mpt-check! "form-infix" (get (mau/op-form "_+_") :kind) "infix")
-(mpt-check! "form-infix-tok" (get (mau/op-form "_+_") :token) "+")
-(mpt-check! "form-prefix" (get (mau/op-form "s_") :kind) "prefix")
-(mpt-check! "form-prefix-tok" (get (mau/op-form "s_") :token) "s")
-(mpt-check! "form-postfix" (get (mau/op-form "_!") :kind) "postfix")
-(mpt-check! "form-const" (get (mau/op-form "nil") :kind) "const")
-(mpt-check!
-  "form-mixfix"
-  (get (mau/op-form "if_then_else_fi") :kind)
-  "mixfix")
-
-;; ---- module header / sorts ----
-
-(mpt-check! "mod-name" (mau/module-name mpt-peano) "PEANO")
-(mpt-check! "mod-kind" (mau/module-kind mpt-peano) "fmod")
-(mpt-check! "mod-sorts" (mau/module-sorts mpt-peano) (list "Nat"))
-(mpt-check!
-  "natlist-sorts-count"
-  (len (mau/module-sorts mpt-natlist))
-  4)
-
-;; ---- subsorts (direct + transitive) ----
-
-(mpt-check! "subsort-direct" (mau/subsort? mpt-natlist "NzNat" "Nat") true)
-(mpt-check! "subsort-trans" (mau/subsort? mpt-natlist "NzNat" "List") true)
-(mpt-check! "subsort-trans2" (mau/subsort? mpt-natlist "Zero" "List") true)
-(mpt-check! "subsort-none" (mau/subsort? mpt-natlist "List" "Nat") false)
-(mpt-check! "sort<=-refl" (mau/sort<=? mpt-natlist "Nat" "Nat") true)
-(mpt-check! "sort<=-trans" (mau/sort<=? mpt-natlist "Zero" "List") true)
-
-;; ---- operators / overloading ----
-
-(mpt-check! "ops-count" (len (mau/module-ops mpt-peano)) 4)
-(mpt-check!
-  "op-arity"
-  (get (first (mau/ops-named mpt-peano "_+_")) :arity)
-  (list "Nat" "Nat"))
-(mpt-check!
-  "op-result"
-  (get (first (mau/ops-named mpt-peano "s_")) :result)
-  "Nat")
-(mpt-check!
-  "op-const-arity"
-  (len (get (first (mau/ops-named mpt-peano "0")) :arity))
-  0)
-(mpt-check!
-  "natlist-ops-count"
-  (len (mau/module-ops mpt-natlist))
-  5)
-
-;; ---- attributes ----
-
-(mpt-check!
-  "attr-assoc"
-  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :assoc)
-  true)
-(mpt-check!
-  "attr-comm"
-  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :comm)
-  true)
-(mpt-check!
-  "attr-prec"
-  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :prec)
-  33)
-(mpt-check!
-  "attr-id"
-  (get (get (first (mau/ops-named mpt-natlist "_;_")) :attrs) :id)
-  "nil")
-(mpt-check!
-  "attr-absent"
-  (get (get (first (mau/ops-named mpt-peano "_*_")) :attrs) :prec)
-  nil)
-
-;; ---- variables ----
-
-(mpt-check! "var-sort" (get (mau/module-vars mpt-peano) "X") "Nat")
-(mpt-check! "var-list-sort" (get (mau/module-vars mpt-natlist) "L") "List")
-
-;; ---- term parsing ----
-
-(mpt-check!
-  "term-const"
-  (mau/term->str (mau/parse-term-in mpt-peano "0"))
-  "0")
-(mpt-check!
-  "term-prefix-mixfix"
-  (mau/term->str (mau/parse-term-in mpt-peano "s 0"))
-  "s_(0)")
-(mpt-check!
-  "term-nested-prefix"
-  (mau/term->str (mau/parse-term-in mpt-peano "s s 0"))
-  "s_(s_(0))")
-(mpt-check!
-  "term-infix"
-  (mau/term->str (mau/parse-term-in mpt-peano "X + Y"))
-  "_+_(X, Y)")
-(mpt-check!
-  "term-prec"
-  (mau/term->str (mau/parse-term-in mpt-peano "s X + Y"))
-  "_+_(s_(X), Y)")
-(mpt-check!
-  "term-paren"
-  (mau/term->str (mau/parse-term-in mpt-peano "s (X + Y)"))
-  "s_(_+_(X, Y))")
-(mpt-check!
-  "term-left-assoc"
-  (mau/term->str (mau/parse-term-in mpt-peano "X + Y + X"))
-  "_+_(_+_(X, Y), X)")
-(mpt-check!
-  "term-prefix-form"
-  (mau/term->str (mau/parse-term-in mpt-peano "_+_(X, 0)"))
-  "_+_(X, 0)")
-(mpt-check!
-  "term-funcall"
-  (mau/term->str (mau/parse-term-in mpt-natlist "length(nil)"))
-  "length(nil)")
-(mpt-check!
-  "term-onthefly-var"
-  (mau/var? (mau/parse-term-in mpt-peano "Z:Nat"))
-  true)
-(mpt-check!
-  "term-onthefly-sort"
-  (mau/vsort (mau/parse-term-in mpt-peano "Z:Nat"))
-  "Nat")
-(mpt-check!
-  "term-var-vs-const"
-  (mau/var? (mau/parse-term-in mpt-peano "X"))
-  true)
-(mpt-check!
-  "term-const-not-var"
-  (mau/var? (mau/parse-term-in mpt-peano "0"))
-  false)
-
-;; ---- equations ----
-
-(mpt-check! "eq-count" (len (mau/module-eqs mpt-peano)) 3)
-(mpt-check!
-  "eq-lhs"
-  (mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :lhs))
-  "_+_(s_(X), Y)")
-(mpt-check!
-  "eq-rhs"
-  (mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :rhs))
-  "s_(_+_(X, Y))")
-(mpt-check!
-  "eq-uncond"
-  (get (nth (mau/module-eqs mpt-peano) 0) :cond)
-  nil)
-(mpt-check!
-  "natlist-eq-head"
-  (mau/term->str (get (nth (mau/module-eqs mpt-natlist) 1) :lhs))
-  "head(_;_(N, L))")
-
-;; ---- conditional equations ----
-
-(define
-  mpt-gcd
-  (mau/parse-module
-    "fmod GCD is\n  sort Nat .\n  op _>_ : Nat Nat -> Bool .\n  op _-_ : Nat Nat -> Nat .\n  op gcd : Nat Nat -> Nat .\n  vars X Y : Nat .\n  ceq gcd(X, Y) = gcd(X - Y, Y) if X > Y = true .\nendfm"))
-
-(mpt-check! "ceq-count" (len (mau/module-eqs mpt-gcd)) 1)
-(mpt-check!
-  "ceq-has-cond"
-  (= (get (first (mau/module-eqs mpt-gcd)) :cond) nil)
-  false)
-(mpt-check!
-  "ceq-cond-kind"
-  (get (get (first (mau/module-eqs mpt-gcd)) :cond) :kind)
-  "eq")
-(mpt-check!
-  "ceq-cond-lhs"
-  (mau/term->str (get (get (first (mau/module-eqs mpt-gcd)) :cond) :lhs))
-  "_>_(X, Y)")
-
-;; ---- system module + rules ----
-
-(define
-  mpt-vending
-  (mau/parse-module
-    "mod VENDING is\n  sort State .\n  op _coin : State -> State .\n  op buy : State -> State .\n  var S : State .\n  rl [insert] : S coin => buy(S) .\n  crl [guard] : buy(S) => S if S = S .\nendfm"))
-
-(mpt-check! "mod-kind-mod" (mau/module-kind mpt-vending) "mod")
-(mpt-check! "rules-count" (len (mau/module-rules mpt-vending)) 2)
-(mpt-check!
-  "rule-label"
-  (get (first (mau/module-rules mpt-vending)) :label)
-  "insert")
-(mpt-check!
-  "rule-rhs"
-  (mau/term->str (get (first (mau/module-rules mpt-vending)) :rhs))
-  "buy(S)")
-(mpt-check!
-  "crl-label"
-  (get (nth (mau/module-rules mpt-vending) 1) :label)
-  "guard")
-(mpt-check!
-  "crl-cond-kind"
-  (get (get (nth (mau/module-rules mpt-vending) 1) :cond) :kind)
-  "eq")
-
-(define mau-parse-tests-run! (fn () {:failures mpt-failures :total (+ mpt-pass mpt-fail) :passed mpt-pass :failed mpt-fail}))