Compare commits
18 Commits
loops/drea
...
loops/maud
| Author | SHA1 | Date | |
|---|---|---|---|
| 2dd4c7d974 | |||
| d2f6bf02b3 | |||
| 7f264b39da | |||
| fe0d13243a | |||
| 6ea9ecf9a4 | |||
| fecd3e4b0d | |||
| 3bb4886f0f | |||
| cc0f3f1ff7 | |||
| d09af71f6e | |||
| ed40af66f5 | |||
| 8ab36b90bf | |||
| 4018671087 | |||
| e2aca38a84 | |||
| 858d35a68c | |||
| 1747bbd944 | |||
| 2378056cb3 | |||
| 10906d4ffc | |||
| 9f87206949 |
@@ -1,79 +0,0 @@
|
||||
# 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).
|
||||
@@ -1,33 +0,0 @@
|
||||
;; 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})))
|
||||
@@ -1,172 +0,0 @@
|
||||
;; 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)))
|
||||
@@ -1,122 +0,0 @@
|
||||
#!/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
|
||||
@@ -1,51 +0,0 @@
|
||||
;; 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))))
|
||||
@@ -1,46 +0,0 @@
|
||||
;; 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)))
|
||||
@@ -1,35 +0,0 @@
|
||||
;; 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)))
|
||||
@@ -1,16 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,96 +0,0 @@
|
||||
;; 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"))
|
||||
@@ -1,41 +0,0 @@
|
||||
;; 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>"))))
|
||||
@@ -1,91 +0,0 @@
|
||||
;; 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))))
|
||||
@@ -1,366 +0,0 @@
|
||||
;; 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)))
|
||||
@@ -1,54 +0,0 @@
|
||||
;; 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)))))
|
||||
@@ -1,24 +0,0 @@
|
||||
;; 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 "&" "&") "<" "<") ">" ">")
|
||||
"\""
|
||||
""")
|
||||
"'"
|
||||
"'")))
|
||||
|
||||
;; 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))))
|
||||
@@ -1,183 +0,0 @@
|
||||
;; 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))))
|
||||
@@ -1,92 +0,0 @@
|
||||
;; 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))))))
|
||||
@@ -1,170 +0,0 @@
|
||||
;; 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))))))
|
||||
@@ -1,42 +0,0 @@
|
||||
;; 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)))
|
||||
@@ -1,238 +0,0 @@
|
||||
;; 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))))
|
||||
@@ -1,182 +0,0 @@
|
||||
;; 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)))
|
||||
@@ -1,77 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,109 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,93 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,198 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,90 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,129 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,226 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,94 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,59 +0,0 @@
|
||||
;; 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>") "<b>")
|
||||
(dream-ht-test "escape quote" (dream-escape "say \"hi\"") "say "hi"")
|
||||
(dream-ht-test "escape apostrophe" (dream-escape "it's") "it's")
|
||||
(dream-ht-test
|
||||
"escape script tag"
|
||||
(dream-escape "<script>alert(1)</script>")
|
||||
"<script>alert(1)</script>")
|
||||
(dream-ht-test
|
||||
"ampersand first (no double-escape)"
|
||||
(dream-escape "<")
|
||||
"&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"b\"")
|
||||
(dream-ht-test
|
||||
"escape-join"
|
||||
(dream-escape-join " " (list "<a>" "<b>"))
|
||||
"<a> <b>")
|
||||
|
||||
;; ── 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 "<script>")
|
||||
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}))
|
||||
@@ -1,105 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,150 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,272 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,123 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,197 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,125 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,199 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,94 +0,0 @@
|
||||
;; 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}))
|
||||
@@ -1,175 +0,0 @@
|
||||
;; 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)))
|
||||
@@ -1,42 +0,0 @@
|
||||
;; 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)))
|
||||
164
lib/maude/conditional.sx
Normal file
164
lib/maude/conditional.sx
Normal file
@@ -0,0 +1,164 @@
|
||||
;; 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))))
|
||||
268
lib/maude/confluence.sx
Normal file
268
lib/maude/confluence.sx
Normal file
@@ -0,0 +1,268 @@
|
||||
;; 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))))))
|
||||
41
lib/maude/conformance.conf
Normal file
41
lib/maude/conformance.conf
Normal file
@@ -0,0 +1,41 @@
|
||||
# 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!)"
|
||||
)
|
||||
3
lib/maude/conformance.sh
Executable file
3
lib/maude/conformance.sh
Executable file
@@ -0,0 +1,3 @@
|
||||
#!/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" "$@"
|
||||
250
lib/maude/fire.sx
Normal file
250
lib/maude/fire.sx
Normal file
@@ -0,0 +1,250 @@
|
||||
;; 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 {}))))))
|
||||
565
lib/maude/matching.sx
Normal file
565
lib/maude/matching.sx
Normal file
@@ -0,0 +1,565 @@
|
||||
;; 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))))
|
||||
104
lib/maude/meta.sx
Normal file
104
lib/maude/meta.sx
Normal file
@@ -0,0 +1,104 @@
|
||||
;; 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))))
|
||||
710
lib/maude/parser.sx
Normal file
710
lib/maude/parser.sx
Normal file
@@ -0,0 +1,710 @@
|
||||
;; 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)))
|
||||
82
lib/maude/pretty.sx
Normal file
82
lib/maude/pretty.sx
Normal file
@@ -0,0 +1,82 @@
|
||||
;; 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))))
|
||||
143
lib/maude/reduce.sx
Normal file
143
lib/maude/reduce.sx
Normal file
@@ -0,0 +1,143 @@
|
||||
;; 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))))
|
||||
284
lib/maude/rewrite.sx
Normal file
284
lib/maude/rewrite.sx
Normal file
@@ -0,0 +1,284 @@
|
||||
;; 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)))))
|
||||
132
lib/maude/run.sx
Normal file
132
lib/maude/run.sx
Normal file
@@ -0,0 +1,132 @@
|
||||
;; 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))))
|
||||
24
lib/maude/scoreboard.json
Normal file
24
lib/maude/scoreboard.json
Normal file
@@ -0,0 +1,24 @@
|
||||
{
|
||||
"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"
|
||||
}
|
||||
21
lib/maude/scoreboard.md
Normal file
21
lib/maude/scoreboard.md
Normal file
@@ -0,0 +1,21 @@
|
||||
# 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 |
|
||||
103
lib/maude/searchpath.sx
Normal file
103
lib/maude/searchpath.sx
Normal file
@@ -0,0 +1,103 @@
|
||||
;; 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)))))
|
||||
87
lib/maude/sorts.sx
Normal file
87
lib/maude/sorts.sx
Normal file
@@ -0,0 +1,87 @@
|
||||
;; 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)))
|
||||
217
lib/maude/strategy.sx
Normal file
217
lib/maude/strategy.sx
Normal file
@@ -0,0 +1,217 @@
|
||||
;; 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))))))
|
||||
114
lib/maude/term.sx
Normal file
114
lib/maude/term.sx
Normal file
@@ -0,0 +1,114 @@
|
||||
;; 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))))))
|
||||
108
lib/maude/tests/conditional.sx
Normal file
108
lib/maude/tests/conditional.sx
Normal file
@@ -0,0 +1,108 @@
|
||||
;; 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}))
|
||||
101
lib/maude/tests/confluence.sx
Normal file
101
lib/maude/tests/confluence.sx
Normal file
@@ -0,0 +1,101 @@
|
||||
;; 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}))
|
||||
79
lib/maude/tests/effects.sx
Normal file
79
lib/maude/tests/effects.sx
Normal file
@@ -0,0 +1,79 @@
|
||||
;; 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}))
|
||||
66
lib/maude/tests/gather.sx
Normal file
66
lib/maude/tests/gather.sx
Normal file
@@ -0,0 +1,66 @@
|
||||
;; 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}))
|
||||
170
lib/maude/tests/matching.sx
Normal file
170
lib/maude/tests/matching.sx
Normal file
@@ -0,0 +1,170 @@
|
||||
;; 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}))
|
||||
144
lib/maude/tests/meta.sx
Normal file
144
lib/maude/tests/meta.sx
Normal file
@@ -0,0 +1,144 @@
|
||||
;; 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}))
|
||||
61
lib/maude/tests/owise.sx
Normal file
61
lib/maude/tests/owise.sx
Normal file
@@ -0,0 +1,61 @@
|
||||
;; 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}))
|
||||
250
lib/maude/tests/parse.sx
Normal file
250
lib/maude/tests/parse.sx
Normal file
@@ -0,0 +1,250 @@
|
||||
;; 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}))
|
||||
50
lib/maude/tests/pretty.sx
Normal file
50
lib/maude/tests/pretty.sx
Normal file
@@ -0,0 +1,50 @@
|
||||
;; lib/maude/tests/pretty.sx — mixfix surface-syntax printer.
|
||||
|
||||
(define mpp-pass 0)
|
||||
(define mpp-fail 0)
|
||||
(define mpp-failures (list))
|
||||
|
||||
(define
|
||||
mpp-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! mpp-pass (+ mpp-pass 1))
|
||||
(do
|
||||
(set! mpp-fail (+ mpp-fail 1))
|
||||
(append!
|
||||
mpp-failures
|
||||
(str name " expected: " expected " got: " got))))))
|
||||
|
||||
(define
|
||||
mpp-m
|
||||
(mau/parse-module
|
||||
"fmod PEANO is\n sort Nat .\n op 0 : -> Nat .\n op s_ : Nat -> Nat .\n op _+_ : Nat Nat -> Nat .\n op _! : Nat -> Nat .\n op f : Nat Nat -> Nat .\n vars X Y : Nat .\n eq 0 + Y = Y .\n eq s X + Y = s (X + Y) .\nendfm"))
|
||||
|
||||
(define
|
||||
mpp-render
|
||||
(fn (src) (mau/term->maude mpp-m (mau/parse-term-in mpp-m src))))
|
||||
|
||||
(mpp-check! "const" (mpp-render "0") "0")
|
||||
(mpp-check! "var" (mau/term->maude mpp-m (mau/var "X" "Nat")) "X")
|
||||
(mpp-check! "prefix" (mpp-render "s 0") "(s 0)")
|
||||
(mpp-check! "infix" (mpp-render "X + Y") "(X + Y)")
|
||||
(mpp-check! "nested" (mpp-render "s X + Y") "((s X) + Y)")
|
||||
(mpp-check! "paren" (mpp-render "s (X + Y)") "(s (X + Y))")
|
||||
;; postfix: built directly (the parser does not produce postfix applications)
|
||||
(mpp-check!
|
||||
"postfix"
|
||||
(mau/term->maude mpp-m (mau/app "_!" (list (mau/var "X" "Nat"))))
|
||||
"(X !)")
|
||||
(mpp-check! "funcall" (mpp-render "f(0, s 0)") "f(0, (s 0))")
|
||||
(mpp-check! "prefix-form-infix" (mpp-render "_+_(0, 0)") "(0 + 0)")
|
||||
|
||||
;; reduce then render in surface syntax
|
||||
(mpp-check!
|
||||
"red-surface"
|
||||
(mau/red->maude mpp-m "s 0 + s s 0")
|
||||
"(s (s (s 0)))")
|
||||
(mpp-check! "red-zero" (mau/red->maude mpp-m "0 + 0") "0")
|
||||
|
||||
(define mau-pretty-tests-run! (fn () {:failures mpp-failures :total (+ mpp-pass mpp-fail) :passed mpp-pass :failed mpp-fail}))
|
||||
120
lib/maude/tests/reduce.sx
Normal file
120
lib/maude/tests/reduce.sx
Normal file
@@ -0,0 +1,120 @@
|
||||
;; lib/maude/tests/reduce.sx — Phase 2: syntactic equational reduction.
|
||||
|
||||
(define mrt-pass 0)
|
||||
(define mrt-fail 0)
|
||||
(define mrt-failures (list))
|
||||
|
||||
(define
|
||||
mrt-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! mrt-pass (+ mrt-pass 1))
|
||||
(do
|
||||
(set! mrt-fail (+ mrt-fail 1))
|
||||
(append!
|
||||
mrt-failures
|
||||
(str name " expected: " expected " got: " got))))))
|
||||
|
||||
;; ---- Peano arithmetic ----
|
||||
|
||||
(define
|
||||
mrt-peano
|
||||
(mau/parse-module
|
||||
"fmod PEANO is\n sort Nat .\n op 0 : -> Nat .\n op s_ : Nat -> Nat .\n op _+_ : Nat 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) .\n eq 0 * Y = 0 .\n eq s X * Y = Y + (X * Y) .\nendfm"))
|
||||
|
||||
(mrt-check!
|
||||
"add-2-1"
|
||||
(mau/reduce->str mrt-peano "s s 0 + s 0")
|
||||
"s_(s_(s_(0)))")
|
||||
(mrt-check! "add-0-0" (mau/reduce->str mrt-peano "0 + 0") "0")
|
||||
(mrt-check! "add-id-left" (mau/reduce->str mrt-peano "0 + s s 0") "s_(s_(0))")
|
||||
(mrt-check!
|
||||
"mul-2-2"
|
||||
(mau/reduce->str mrt-peano "s s 0 * s s 0")
|
||||
"s_(s_(s_(s_(0))))")
|
||||
(mrt-check! "mul-zero" (mau/reduce->str mrt-peano "0 * s s s 0") "0")
|
||||
(mrt-check! "mul-by-zero" (mau/reduce->str mrt-peano "s s 0 * 0") "0")
|
||||
(mrt-check!
|
||||
"nested"
|
||||
(mau/reduce->str mrt-peano "(s 0 + s 0) * s s 0")
|
||||
"s_(s_(s_(s_(0))))")
|
||||
|
||||
;; ---- list manipulation ----
|
||||
|
||||
(define
|
||||
mrt-list
|
||||
(mau/parse-module
|
||||
"fmod NATLIST is\n sorts Nat List .\n op 0 : -> Nat .\n op s_ : Nat -> Nat .\n op nil : -> List .\n op cons : Nat List -> List .\n op append : List List -> List .\n op length : List -> Nat .\n op rev : List -> List .\n var X : Nat .\n vars L M : List .\n eq append(nil, M) = M .\n eq append(cons(X, L), M) = cons(X, append(L, M)) .\n eq length(nil) = 0 .\n eq length(cons(X, L)) = s length(L) .\n eq rev(nil) = nil .\n eq rev(cons(X, L)) = append(rev(L), cons(X, nil)) .\nendfm"))
|
||||
|
||||
(mrt-check!
|
||||
"append"
|
||||
(mau/reduce->str mrt-list "append(cons(0, nil), cons(s 0, nil))")
|
||||
"cons(0, cons(s_(0), nil))")
|
||||
(mrt-check!
|
||||
"append-nil"
|
||||
(mau/reduce->str mrt-list "append(nil, cons(0, nil))")
|
||||
"cons(0, nil)")
|
||||
(mrt-check!
|
||||
"length-2"
|
||||
(mau/reduce->str mrt-list "length(cons(0, cons(s 0, nil)))")
|
||||
"s_(s_(0))")
|
||||
(mrt-check! "length-0" (mau/reduce->str mrt-list "length(nil)") "0")
|
||||
(mrt-check!
|
||||
"rev"
|
||||
(mau/reduce->str mrt-list "rev(cons(0, cons(s 0, nil)))")
|
||||
"cons(s_(0), cons(0, nil))")
|
||||
(mrt-check! "rev-empty" (mau/reduce->str mrt-list "rev(nil)") "nil")
|
||||
|
||||
;; ---- propositional logic simplifier ----
|
||||
|
||||
(define
|
||||
mrt-prop
|
||||
(mau/parse-module
|
||||
"fmod PROPLOGIC is\n sort Bool .\n op tt : -> Bool .\n op ff : -> Bool .\n op not_ : Bool -> Bool .\n op _and_ : Bool Bool -> Bool .\n op _or_ : Bool Bool -> Bool .\n op _xor_ : Bool Bool -> Bool .\n vars P Q : Bool .\n eq not tt = ff .\n eq not ff = tt .\n eq tt and P = P .\n eq ff and P = ff .\n eq tt or P = tt .\n eq ff or P = P .\n eq P xor ff = P .\n eq P xor tt = not P .\nendfm"))
|
||||
|
||||
(mrt-check! "not-tt" (mau/reduce->str mrt-prop "not tt") "ff")
|
||||
(mrt-check! "and-simpl" (mau/reduce->str mrt-prop "not (tt and ff)") "tt")
|
||||
(mrt-check! "or-simpl" (mau/reduce->str mrt-prop "ff or (tt and tt)") "tt")
|
||||
(mrt-check! "double-neg" (mau/reduce->str mrt-prop "not not tt") "tt")
|
||||
(mrt-check! "xor-id" (mau/reduce->str mrt-prop "tt xor ff") "tt")
|
||||
(mrt-check! "xor-tt" (mau/reduce->str mrt-prop "ff xor tt") "tt")
|
||||
(mrt-check!
|
||||
"deep"
|
||||
(mau/reduce->str mrt-prop "(tt and tt) or (not not ff)")
|
||||
"tt")
|
||||
|
||||
;; ---- non-linear pattern (repeated variable) + no-match leaves term ----
|
||||
|
||||
(define
|
||||
mrt-same
|
||||
(mau/parse-module
|
||||
"fmod SAME is\n sorts Elt Bool .\n op a : -> Elt .\n op b : -> Elt .\n op tt : -> Bool .\n op same : Elt Elt -> Bool .\n var X : Elt .\n eq same(X, X) = tt .\nendfm"))
|
||||
|
||||
(mrt-check! "nonlinear-match" (mau/reduce->str mrt-same "same(a, a)") "tt")
|
||||
(mrt-check!
|
||||
"nonlinear-nomatch"
|
||||
(mau/reduce->str mrt-same "same(a, b)")
|
||||
"same(a, b)")
|
||||
(mrt-check! "no-rule-stays" (mau/reduce->str mrt-same "b") "b")
|
||||
|
||||
;; ---- low-level matching ----
|
||||
|
||||
(mrt-check!
|
||||
"match-var-binds"
|
||||
(= nil (mau/match (mau/var "X" "Nat") (mau/const "0") {}))
|
||||
false)
|
||||
(mrt-check!
|
||||
"match-mismatch"
|
||||
(mau/match (mau/const "0") (mau/const "1") {})
|
||||
nil)
|
||||
(mrt-check!
|
||||
"subst-apply"
|
||||
(mau/term->str
|
||||
(mau/subst-apply
|
||||
(assoc {} "X" (mau/const "0"))
|
||||
(mau/app "s_" (list (mau/var "X" "Nat")))))
|
||||
"s_(0)")
|
||||
|
||||
(define mau-reduce-tests-run! (fn () {:failures mrt-failures :total (+ mrt-pass mrt-fail) :passed mrt-pass :failed mrt-fail}))
|
||||
114
lib/maude/tests/rewrite.sx
Normal file
114
lib/maude/tests/rewrite.sx
Normal file
@@ -0,0 +1,114 @@
|
||||
;; lib/maude/tests/rewrite.sx — Phase 5: system modules + rewrite rules.
|
||||
|
||||
(define mrw-pass 0)
|
||||
(define mrw-fail 0)
|
||||
(define mrw-failures (list))
|
||||
|
||||
(define
|
||||
mrw-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! mrw-pass (+ mrw-pass 1))
|
||||
(do
|
||||
(set! mrw-fail (+ mrw-fail 1))
|
||||
(append!
|
||||
mrw-failures
|
||||
(str name " expected: " expected " got: " got))))))
|
||||
|
||||
;; ---- AC multiset transition (the headline: rule on a sub-multiset) ----
|
||||
|
||||
(define
|
||||
mrw-coins
|
||||
(mau/parse-module
|
||||
"mod COINS is\n sort Marking .\n op nil : -> Marking .\n op q : -> Marking .\n op d : -> Marking .\n op _;_ : Marking Marking -> Marking [assoc comm id: nil] .\n rl [change] : q ; q ; q ; q => d .\nendm"))
|
||||
|
||||
(mrw-check! "coins-kind" (mau/module-kind mrw-coins) "mod")
|
||||
(mrw-check! "coins-rules" (len (mau/module-rules mrw-coins)) 1)
|
||||
(mrw-check! "coins-exact" (mau/rewrite-canon mrw-coins "q ; q ; q ; q") "d")
|
||||
(mrw-check!
|
||||
"coins-5"
|
||||
(mau/rewrite-canon mrw-coins "q ; q ; q ; q ; q")
|
||||
"_;_(d,q)")
|
||||
(mrw-check!
|
||||
"coins-8"
|
||||
(mau/rewrite-canon mrw-coins "q ; q ; q ; q ; q ; q ; q ; q")
|
||||
"_;_(d,d)")
|
||||
(mrw-check!
|
||||
"coins-3-stuck"
|
||||
(mau/rewrite-canon mrw-coins "q ; q ; q")
|
||||
"_;_(q,q,q)")
|
||||
|
||||
;; ---- cyclic state machine (bounded rew) ----
|
||||
|
||||
(define
|
||||
mrw-traffic
|
||||
(mau/parse-module
|
||||
"mod TRAFFIC is\n sort Light .\n ops red green yellow : -> Light .\n rl [g] : red => green .\n rl [y] : green => yellow .\n rl [r] : yellow => red .\nendm"))
|
||||
|
||||
(mrw-check! "traffic-1" (mau/rew->str mrw-traffic "red" 1) "green")
|
||||
(mrw-check! "traffic-2" (mau/rew->str mrw-traffic "red" 2) "yellow")
|
||||
(mrw-check! "traffic-3" (mau/rew->str mrw-traffic "red" 3) "red")
|
||||
(mrw-check! "traffic-0" (mau/rew->str mrw-traffic "green" 0) "green")
|
||||
|
||||
;; ---- nondeterministic branching: rew (one path) vs search (all paths) ----
|
||||
|
||||
(define
|
||||
mrw-ndet
|
||||
(mau/parse-module
|
||||
"mod NDET is\n sort S .\n ops a b c d goal : -> S .\n rl [r1] : a => b .\n rl [r2] : a => c .\n rl [r3] : b => d .\n rl [r4] : c => goal .\nendm"))
|
||||
|
||||
;; rew takes the first rule each step: a -> b -> d (stuck), never reaches goal.
|
||||
(mrw-check! "ndet-rew-path" (mau/rewrite->str mrw-ndet "a") "d")
|
||||
(mrw-check! "ndet-succ" (mau/successors mrw-ndet "a") (list "b" "c"))
|
||||
(mrw-check!
|
||||
"ndet-search-goal"
|
||||
(mau/search mrw-ndet "a" "goal" 5)
|
||||
true)
|
||||
(mrw-check!
|
||||
"ndet-search-shallow"
|
||||
(mau/search mrw-ndet "a" "goal" 1)
|
||||
false)
|
||||
(mrw-check! "ndet-search-self" (mau/search mrw-ndet "a" "a" 3) true)
|
||||
(mrw-check! "ndet-search-d" (mau/search mrw-ndet "a" "d" 5) true)
|
||||
|
||||
;; ---- conditional rule (crl with equational guard) ----
|
||||
|
||||
(define
|
||||
mrw-clock
|
||||
(mau/parse-module
|
||||
"mod CLOCK 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 clk : Nat -> Nat .\n vars M N : Nat .\n eq 0 < s N = true .\n eq N < 0 = false .\n eq s M < s N = M < N .\n crl [tick] : clk(N) => clk(s N) if N < s s s 0 = true .\nendm"))
|
||||
|
||||
;; tick fires while N < 3, then stops at clk(3).
|
||||
(mrw-check!
|
||||
"clock-run"
|
||||
(mau/rewrite->str mrw-clock "clk(0)")
|
||||
"clk(s_(s_(s_(0))))")
|
||||
(mrw-check!
|
||||
"clock-from-1"
|
||||
(mau/rewrite->str mrw-clock "clk(s 0)")
|
||||
"clk(s_(s_(s_(0))))")
|
||||
(mrw-check!
|
||||
"clock-step1"
|
||||
(mau/rew->str mrw-clock "clk(0)" 1)
|
||||
"clk(s_(0))")
|
||||
|
||||
;; ---- eqs interleave with rules ----
|
||||
|
||||
(define
|
||||
mrw-mix
|
||||
(mau/parse-module
|
||||
"mod MIX is\n sort Nat .\n op 0 : -> Nat .\n op s_ : Nat -> Nat .\n op _+_ : Nat Nat -> Nat .\n op f : Nat -> Nat .\n vars X Y : Nat .\n eq 0 + Y = Y .\n eq s X + Y = s (X + Y) .\n rl [step] : f(X) => f(X + s 0) .\nendm"))
|
||||
|
||||
;; each rule step adds one (via the rule), eqs normalise the sum.
|
||||
(mrw-check!
|
||||
"mix-step1"
|
||||
(mau/rew->str mrw-mix "f(s 0)" 1)
|
||||
"f(s_(s_(0)))")
|
||||
(mrw-check!
|
||||
"mix-step2"
|
||||
(mau/rew->str mrw-mix "f(0)" 2)
|
||||
"f(s_(s_(0)))")
|
||||
|
||||
(define mau-rewrite-tests-run! (fn () {:failures mrw-failures :total (+ mrw-pass mrw-fail) :passed mrw-pass :failed mrw-fail}))
|
||||
79
lib/maude/tests/run.sx
Normal file
79
lib/maude/tests/run.sx
Normal file
@@ -0,0 +1,79 @@
|
||||
;; lib/maude/tests/run.sx — running a Maude program (module + commands).
|
||||
|
||||
(define mrn-pass 0)
|
||||
(define mrn-fail 0)
|
||||
(define mrn-failures (list))
|
||||
|
||||
(define
|
||||
mrn-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! mrn-pass (+ mrn-pass 1))
|
||||
(do
|
||||
(set! mrn-fail (+ mrn-fail 1))
|
||||
(append!
|
||||
mrn-failures
|
||||
(str name " expected: " expected " got: " got))))))
|
||||
|
||||
(define
|
||||
mrn-peano
|
||||
"fmod PEANO is\n sorts Nat NzNat .\n subsort NzNat < Nat .\n op 0 : -> Nat .\n op s_ : Nat -> NzNat .\n op _+_ : Nat 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) .\n eq 0 * Y = 0 .\n eq s X * Y = Y + (X * Y) .\nendfm\nred s 0 + s s 0 .\nred 0 + 0 .\nreduce in PEANO : s s 0 * s s 0 .")
|
||||
|
||||
(mrn-check!
|
||||
"peano-results"
|
||||
(mau/run mrn-peano)
|
||||
(list "(s (s (s 0)))" "0" "(s (s (s (s 0))))"))
|
||||
|
||||
(mrn-check! "peano-count" (len (mau/run-program mrn-peano)) 3)
|
||||
(mrn-check!
|
||||
"peano-cmd-kind"
|
||||
(get (first (mau/run-program mrn-peano)) :cmd)
|
||||
"reduce")
|
||||
|
||||
;; least-sort annotated output: s_ : Nat -> NzNat, so s(...) is NzNat
|
||||
(mrn-check!
|
||||
"peano-pretty"
|
||||
(mau/run-pretty mrn-peano)
|
||||
(list
|
||||
"result NzNat: (s (s (s 0)))"
|
||||
"result Nat: 0"
|
||||
"result NzNat: (s (s (s (s 0))))"))
|
||||
|
||||
(define
|
||||
mrn-coins
|
||||
"mod COINS is\n sort M .\n op nil : -> M .\n op q : -> M .\n op d : -> M .\n op _;_ : M M -> M [assoc comm id: nil] .\n rl [change] : q ; q ; q ; q => d .\nendm\nrew q ; q ; q ; q ; q .\nrewrite q ; q ; q ; q ; q ; q ; q ; q .")
|
||||
|
||||
(mrn-check! "coins-results" (mau/run mrn-coins) (list "(d ; q)" "(d ; d)"))
|
||||
|
||||
(mrn-check!
|
||||
"coins-cmd-kind"
|
||||
(get (first (mau/run-program mrn-coins)) :cmd)
|
||||
"rewrite")
|
||||
|
||||
;; search command
|
||||
(define
|
||||
mrn-ndet
|
||||
"mod NDET is\n sort S .\n ops a b c goal : -> S .\n rl [r1] : a => b .\n rl [r2] : a => c .\n rl [r3] : c => goal .\nendm\nsearch a =>* goal .\nsearch a =>* b .\nsearch b =>* goal .")
|
||||
|
||||
(mrn-check!
|
||||
"search-results"
|
||||
(mau/run mrn-ndet)
|
||||
(list "a => c => goal" "a => b" "no solution"))
|
||||
(mrn-check!
|
||||
"search-cmd-kind"
|
||||
(get (first (mau/run-program mrn-ndet)) :cmd)
|
||||
"search")
|
||||
(mrn-check!
|
||||
"search-pretty"
|
||||
(first (mau/run-pretty mrn-ndet))
|
||||
"search: a => c => goal")
|
||||
|
||||
;; module-only (no commands) runs to an empty result list
|
||||
(mrn-check!
|
||||
"no-commands"
|
||||
(mau/run "fmod EMPTY is\n sort S .\n op a : -> S .\nendfm")
|
||||
(list))
|
||||
|
||||
(define mau-run-tests-run! (fn () {:failures mrn-failures :total (+ mrn-pass mrn-fail) :passed mrn-pass :failed mrn-fail}))
|
||||
66
lib/maude/tests/searchpath.sx
Normal file
66
lib/maude/tests/searchpath.sx
Normal file
@@ -0,0 +1,66 @@
|
||||
;; lib/maude/tests/searchpath.sx — search returning the witness path.
|
||||
|
||||
(define msp-pass 0)
|
||||
(define msp-fail 0)
|
||||
(define msp-failures (list))
|
||||
|
||||
(define
|
||||
msp-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! msp-pass (+ msp-pass 1))
|
||||
(do
|
||||
(set! msp-fail (+ msp-fail 1))
|
||||
(append!
|
||||
msp-failures
|
||||
(str name " expected: " expected " got: " got))))))
|
||||
|
||||
(define
|
||||
msp-ndet
|
||||
(mau/parse-module
|
||||
"mod NDET is\n sort S .\n ops a b c d goal : -> S .\n rl [r1] : a => b .\n rl [r2] : a => c .\n rl [r3] : b => d .\n rl [r4] : c => goal .\nendm"))
|
||||
|
||||
;; shortest path a -> c -> goal
|
||||
(msp-check!
|
||||
"path-to-goal"
|
||||
(mau/search-path msp-ndet "a" "goal" 5)
|
||||
(list "a" "c" "goal"))
|
||||
(msp-check!
|
||||
"path-length"
|
||||
(mau/search-length msp-ndet "a" "goal" 5)
|
||||
2)
|
||||
(msp-check!
|
||||
"path-self"
|
||||
(mau/search-path msp-ndet "a" "a" 3)
|
||||
(list "a"))
|
||||
(msp-check!
|
||||
"path-one-step"
|
||||
(mau/search-path msp-ndet "a" "b" 3)
|
||||
(list "a" "b"))
|
||||
(msp-check!
|
||||
"path-unreachable"
|
||||
(mau/search-path msp-ndet "d" "goal" 5)
|
||||
nil)
|
||||
(msp-check!
|
||||
"path-depth-limited"
|
||||
(mau/search-path msp-ndet "a" "goal" 1)
|
||||
nil)
|
||||
|
||||
;; a counter that ticks up: path shows each state
|
||||
(define
|
||||
msp-walk
|
||||
(mau/parse-module
|
||||
"mod WALK is\n sort Pos .\n op z : -> Pos .\n op s : Pos -> Pos .\n op p : Pos -> Pos .\n var X : Pos .\n rl [step] : p(X) => p(s(X)) .\nendm"))
|
||||
|
||||
(msp-check!
|
||||
"walk-path"
|
||||
(mau/search-path msp-walk "p(z)" "p(s(s(z)))" 5)
|
||||
(list "p(z)" "p(s(z))" "p(s(s(z)))"))
|
||||
(msp-check!
|
||||
"walk-length"
|
||||
(mau/search-length msp-walk "p(z)" "p(s(s(s(z))))" 6)
|
||||
3)
|
||||
|
||||
(define mau-searchpath-tests-run! (fn () {:failures msp-failures :total (+ msp-pass msp-fail) :passed msp-pass :failed msp-fail}))
|
||||
53
lib/maude/tests/sorts.sx
Normal file
53
lib/maude/tests/sorts.sx
Normal file
@@ -0,0 +1,53 @@
|
||||
;; lib/maude/tests/sorts.sx — order-sorted least-sort inference.
|
||||
|
||||
(define mso-pass 0)
|
||||
(define mso-fail 0)
|
||||
(define mso-failures (list))
|
||||
|
||||
(define
|
||||
mso-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! mso-pass (+ mso-pass 1))
|
||||
(do
|
||||
(set! mso-fail (+ mso-fail 1))
|
||||
(append!
|
||||
mso-failures
|
||||
(str name " expected: " expected " got: " got))))))
|
||||
|
||||
(define
|
||||
mso-m
|
||||
(mau/parse-module
|
||||
"fmod NUMS is\n sorts Zero NzNat Nat .\n subsort Zero < Nat .\n subsort NzNat < Nat .\n op 0 : -> Zero .\n op 1 : -> NzNat .\n op s_ : Nat -> Nat .\n op _+_ : Nat Nat -> Nat .\n op p : NzNat -> NzNat .\n op f : Nat -> Nat .\n op f : NzNat -> NzNat .\nendfm"))
|
||||
|
||||
;; constants take their declared result sort
|
||||
(mso-check! "sort-zero" (mau/term-sort-src mso-m "0") "Zero")
|
||||
(mso-check! "sort-one" (mau/term-sort-src mso-m "1") "NzNat")
|
||||
|
||||
;; application: arg subsort of declared domain
|
||||
(mso-check! "sort-s0" (mau/term-sort-src mso-m "s 0") "Nat")
|
||||
(mso-check! "sort-plus" (mau/term-sort-src mso-m "0 + 1") "Nat")
|
||||
(mso-check! "sort-p" (mau/term-sort-src mso-m "p(1)") "NzNat")
|
||||
|
||||
;; variable keeps its sort
|
||||
(mso-check! "sort-var" (mau/term-sort mso-m (mau/var "X" "Nat")) "Nat")
|
||||
|
||||
;; LEAST sort under overloading: f(1) fits both f decls -> the smaller, NzNat
|
||||
(mso-check! "least-f-1" (mau/term-sort-src mso-m "f(1)") "NzNat")
|
||||
;; f(s 0): s 0 is Nat, only fits f : Nat -> Nat
|
||||
(mso-check! "least-f-s0" (mau/term-sort-src mso-m "f(s 0)") "Nat")
|
||||
;; nested: f(f(1)) -> f(NzNat) -> NzNat
|
||||
(mso-check! "least-nested" (mau/term-sort-src mso-m "f(f(1))") "NzNat")
|
||||
|
||||
;; membership-style sort checks
|
||||
(mso-check! "has-zero-nat" (mau/has-sort-src? mso-m "0" "Nat") true)
|
||||
(mso-check! "has-one-nat" (mau/has-sort-src? mso-m "1" "Nat") true)
|
||||
(mso-check! "has-zero-not-nznat" (mau/has-sort-src? mso-m "0" "NzNat") false)
|
||||
(mso-check! "has-refl" (mau/has-sort-src? mso-m "1" "NzNat") true)
|
||||
|
||||
;; unknown operator -> "?"
|
||||
(mso-check! "sort-unknown" (mau/term-sort mso-m (mau/const "ghost")) "?")
|
||||
|
||||
(define mau-sorts-tests-run! (fn () {:failures mso-failures :total (+ mso-pass mso-fail) :passed mso-pass :failed mso-fail}))
|
||||
151
lib/maude/tests/strategy.sx
Normal file
151
lib/maude/tests/strategy.sx
Normal file
@@ -0,0 +1,151 @@
|
||||
;; lib/maude/tests/strategy.sx — Phase 6: strategy language.
|
||||
|
||||
(define mst-pass 0)
|
||||
(define mst-fail 0)
|
||||
(define mst-failures (list))
|
||||
|
||||
(define
|
||||
mst-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! mst-pass (+ mst-pass 1))
|
||||
(do
|
||||
(set! mst-fail (+ mst-fail 1))
|
||||
(append!
|
||||
mst-failures
|
||||
(str name " expected: " expected " got: " got))))))
|
||||
|
||||
;; ---- a branching system; meaning depends on the strategy ----
|
||||
|
||||
(define
|
||||
mst-mod
|
||||
(mau/parse-module
|
||||
"mod CHOICE is\n sort S .\n ops a b c x y : -> S .\n rl [r1] : a => b .\n rl [r2] : b => c .\n rl [toX] : a => x .\n rl [toY] : a => y .\nendm"))
|
||||
|
||||
(define mst-env {})
|
||||
(dict-set! mst-env "twice" (mau/s-seq (mau/s-rule "r1") (mau/s-rule "r2")))
|
||||
(dict-set! mst-env "anyplus" (mau/s-plus (mau/s-all)))
|
||||
(dict-set! mst-env "norm" (mau/s-bang (mau/s-all)))
|
||||
|
||||
;; basic combinators
|
||||
(mst-check!
|
||||
"idle"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-idle) "a")
|
||||
(list "a"))
|
||||
(mst-check! "fail" (mau/srun-canon mst-mod mst-env (mau/s-fail) "a") (list))
|
||||
(mst-check!
|
||||
"single-rule"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-rule "r1") "a")
|
||||
(list "b"))
|
||||
(mst-check!
|
||||
"single-rule-x"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-rule "toX") "a")
|
||||
(list "x"))
|
||||
(mst-check!
|
||||
"all"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-all) "a")
|
||||
(list "b" "x" "y"))
|
||||
|
||||
;; sequencing: order matters
|
||||
(mst-check!
|
||||
"seq-ok"
|
||||
(mau/srun-canon
|
||||
mst-mod
|
||||
mst-env
|
||||
(mau/s-seq (mau/s-rule "r1") (mau/s-rule "r2"))
|
||||
"a")
|
||||
(list "c"))
|
||||
(mst-check!
|
||||
"seq-fail"
|
||||
(mau/srun-canon
|
||||
mst-mod
|
||||
mst-env
|
||||
(mau/s-seq (mau/s-rule "r2") (mau/s-rule "r1"))
|
||||
"a")
|
||||
(list))
|
||||
|
||||
;; alternation: union
|
||||
(mst-check!
|
||||
"alt"
|
||||
(mau/srun-canon
|
||||
mst-mod
|
||||
mst-env
|
||||
(mau/s-alt (mau/s-rule "toX") (mau/s-rule "toY"))
|
||||
"a")
|
||||
(list "x" "y"))
|
||||
(mst-check!
|
||||
"alt-with-fail"
|
||||
(mau/srun-canon
|
||||
mst-mod
|
||||
mst-env
|
||||
(mau/s-alt (mau/s-rule "r2") (mau/s-rule "r1"))
|
||||
"a")
|
||||
(list "b"))
|
||||
|
||||
;; iteration
|
||||
(mst-check!
|
||||
"star"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-star (mau/s-all)) "a")
|
||||
(list "a" "b" "c" "x" "y"))
|
||||
(mst-check!
|
||||
"plus"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-plus (mau/s-all)) "a")
|
||||
(list "b" "c" "x" "y"))
|
||||
(mst-check!
|
||||
"bang-normal-forms"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-bang (mau/s-all)) "a")
|
||||
(list "c" "x" "y"))
|
||||
(mst-check!
|
||||
"star-from-b"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-star (mau/s-all)) "b")
|
||||
(list "b" "c"))
|
||||
|
||||
;; named strategies + strategy expressions as values
|
||||
(mst-check!
|
||||
"named-twice"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-name "twice") "a")
|
||||
(list "c"))
|
||||
(mst-check!
|
||||
"named-anyplus"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-name "anyplus") "a")
|
||||
(list "b" "c" "x" "y"))
|
||||
(mst-check!
|
||||
"named-norm"
|
||||
(mau/srun-canon mst-mod mst-env (mau/s-name "norm") "a")
|
||||
(list "c" "x" "y"))
|
||||
|
||||
;; nested composition: (r1 ; r2) | toX
|
||||
(mst-check!
|
||||
"nested"
|
||||
(mau/srun-canon
|
||||
mst-mod
|
||||
mst-env
|
||||
(mau/s-alt
|
||||
(mau/s-seq (mau/s-rule "r1") (mau/s-rule "r2"))
|
||||
(mau/s-rule "toX"))
|
||||
"a")
|
||||
(list "c" "x"))
|
||||
|
||||
;; ---- a 1-D walk: strategy chooses how far ----
|
||||
|
||||
(define
|
||||
mst-walk
|
||||
(mau/parse-module
|
||||
"mod WALK is\n sort Pos .\n op 0 : -> Pos .\n op s_ : Pos -> Pos .\n op p : Pos -> Pos .\n var X : Pos .\n rl [step] : p(X) => p(s X) .\nendm"))
|
||||
|
||||
(mst-check!
|
||||
"walk-one"
|
||||
(mau/srun-canon mst-walk {} (mau/s-rule "step") "p(0)")
|
||||
(list "p(s_(0))"))
|
||||
(mst-check!
|
||||
"walk-twice"
|
||||
(mau/srun-canon
|
||||
mst-walk
|
||||
{}
|
||||
(mau/s-seq (mau/s-rule "step") (mau/s-rule "step"))
|
||||
"p(0)")
|
||||
(list "p(s_(s_(0)))"))
|
||||
|
||||
(define mau-strategy-tests-run! (fn () {:failures mst-failures :total (+ mst-pass mst-fail) :passed mst-pass :failed mst-fail}))
|
||||
@@ -44,127 +44,42 @@ The user-facing story: rose-ash users who'd never touch s-expressions might writ
|
||||
|
||||
The five types: `request`, `response`, `handler = request -> response`, `middleware = handler -> handler`, `route`. Everything else is a function over these.
|
||||
|
||||
- [x] **Core types** in `lib/dream/types.sx`: request/response records, route record.
|
||||
- [x] **Router** in `lib/dream/router.sx`:
|
||||
- [ ] **Core types** in `lib/dream/types.sx`: request/response records, route record.
|
||||
- [ ] **Router** in `lib/dream/router.sx`:
|
||||
- `dream-get path handler`, `dream-post path handler`, etc. for all HTTP methods.
|
||||
- `dream-scope prefix middlewares routes` — prefix mount with middleware chain.
|
||||
- `dream-router routes` — dispatch tree, returns handler; no match → 404.
|
||||
- Path param extraction: `:name` segments, `**` wildcard.
|
||||
- `dream-param req name` — retrieve matched path param.
|
||||
- [x] **Middleware** in `lib/dream/middleware.sx`:
|
||||
- [ ] **Middleware** in `lib/dream/middleware.sx`:
|
||||
- `dream-pipeline middlewares handler` — compose middleware left-to-right.
|
||||
- `dream-no-middleware` — identity.
|
||||
- Logger: `(dream-logger next req)` — logs method, path, status, timing.
|
||||
- Content-type sniffer.
|
||||
- [x] **Sessions** in `lib/dream/session.sx`:
|
||||
- [ ] **Sessions** in `lib/dream/session.sx`:
|
||||
- Cookie-backed session middleware.
|
||||
- `dream-session-field req key`, `dream-set-session-field req key val`.
|
||||
- `dream-invalidate-session req`.
|
||||
- [x] **Flash messages** in `lib/dream/flash.sx`:
|
||||
- [ ] **Flash messages** in `lib/dream/flash.sx`:
|
||||
- `dream-flash-middleware` — single-request cookie store.
|
||||
- `dream-add-flash-message req category msg`.
|
||||
- `dream-flash-messages req` — returns list of `(category, msg)`.
|
||||
- [x] **Forms + CSRF** in `lib/dream/form.sx`:
|
||||
- [x] `dream-form req` — returns `(Ok fields)` or `(Err :csrf-token-invalid)`.
|
||||
- [x] `dream-multipart req` — multipart form data (in-memory, not yet streaming).
|
||||
- [x] CSRF middleware: stateless signed tokens, session-scoped.
|
||||
- [x] `dream-csrf-tag req` — returns hidden input fragment for SX templates.
|
||||
- [x] **WebSockets** in `lib/dream/websocket.sx`:
|
||||
- [ ] **Forms + CSRF** in `lib/dream/form.sx`:
|
||||
- `dream-form req` — returns `(Ok fields)` or `(Err :csrf-token-invalid)`.
|
||||
- `dream-multipart req` — streaming multipart form data.
|
||||
- CSRF middleware: stateless signed tokens, session-scoped.
|
||||
- `dream-csrf-tag req` — returns hidden input fragment for SX templates.
|
||||
- [ ] **WebSockets** in `lib/dream/websocket.sx`:
|
||||
- `dream-websocket handler` — upgrades request; handler `(fn (ws) ...)`.
|
||||
- `dream-send ws msg`, `dream-receive ws`, `dream-close ws`.
|
||||
- [x] **Static files:** `dream-static root-path` — serves files, ETags, range requests.
|
||||
- [x] **`dream-run`**: wires root handler into SX's `perform (:http-listen ...)`.
|
||||
- [x] **Demos** in `lib/dream/demos/`:
|
||||
- [x] `hello.ml` → `lib/dream/demos/hello.sx`: "Hello, World!" route.
|
||||
- [x] `counter.ml` → `lib/dream/demos/counter.sx`: in-memory counter with sessions.
|
||||
- [x] `chat.ml` → `lib/dream/demos/chat.sx`: multi-room WebSocket chat.
|
||||
- [x] `todo.ml` → `lib/dream/demos/todo.sx`: CRUD list with forms + CSRF.
|
||||
- [x] Tests in `lib/dream/tests/`: routing dispatch, middleware composition, session round-trip, CSRF accept/reject, flash read-after-write — **258 tests across 10 suites** (well past the 60+ target). Runner: `lib/dream/conformance.sh`.
|
||||
|
||||
**Roadmap complete (2026-06-07): all boxes ticked, 258/258 green.** Loop continues
|
||||
with extensions + hardening below.
|
||||
- **2026-06-07 — Ext: router HTTP correctness** (router suite 27→36, 267 total).
|
||||
Dispatch now tracks which routes' *paths* matched: path matched + method didn't →
|
||||
`405 Method Not Allowed` with an `Allow` header listing the path's methods (was a
|
||||
blanket 404); genuinely-absent paths stay 404. `HEAD` falls back to the matching
|
||||
`GET` handler with the body blanked but headers kept. `dr/route-params` (path-only
|
||||
match) + `dr/method-accepts?` (ANY / HEAD→GET) + `dream-method-not-allowed`. NOTE:
|
||||
in this worktree every `sx-tree` *edit* tool (`sx_replace_node`,
|
||||
`sx_replace_by_pattern`, `sx_insert_near`) raises a yojson `Expected string, got
|
||||
null` error — only `sx_write_file` works, so edits rewrite the whole file.
|
||||
- **2026-06-07 — Ext: error handling + status phrases** (`lib/dream/error.sx`, 15
|
||||
tests, 282 total). `dream-status-text` / `dream-status-line` reason-phrase map (string
|
||||
keys); `dream-status-page` renders a status page. `dream-catch` is a `guard`-based
|
||||
middleware that turns a raised error into a 500 (`dream-catch-with on-error` for a
|
||||
custom page receiving `(req e)`); normal responses pass through untouched, composes
|
||||
around a router. (`guard` catches explicit `(error …)` raises; `e` stringifies to the
|
||||
message.)
|
||||
- **2026-06-07 — Ext: CORS** (`lib/dream/cors.sx`, 12 tests, 294 total). `dream-cors`
|
||||
decorates responses with `Access-Control-Allow-Origin` (+ credentials), and
|
||||
short-circuits preflight `OPTIONS` with a 204 carrying Allow-Methods/Headers/Max-Age.
|
||||
`dream-cors-origin` for a specific origin, `dream-cors-with opts` for full control
|
||||
(origin/methods/headers/credentials/max-age). Composes around a router.
|
||||
- **2026-06-07 — Ext: JSON** (`lib/dream/json.sx`, 35 tests, 329 total). Host JSON
|
||||
primitives live in the ocaml-on-sx runtime (not the base env), so Dream ships its own
|
||||
pure-SX `dream-json-encode` (scalars/list/dict, string escaping) + `dream-json-parse`
|
||||
(recursive-descent over chars, objects/arrays/strings/numbers/true/false/null,
|
||||
whitespace-tolerant). `dream-json-value` (encode → application/json response) and
|
||||
`dream-json-body` (parse request body). GOTCHA: `number?` is unreliable in this env —
|
||||
used `(= (type-of v) "number")`; `parse-float` handles decimals. Multi-key dict
|
||||
encode order follows `keys` (non-deterministic) so tests assert via parse round-trip.
|
||||
- **2026-06-07 — Ext: signed session cookies** (`lib/dream/session.sx`, session suite
|
||||
30→41, 340 total). The default store uses guessable sids (`s1`, `s2`), so
|
||||
`dream-sessions-signed backend secret` signs the cookie value (`sid.signature`) and
|
||||
rejects any cookie whose signature doesn't verify — a forged plaintext `s1` or a
|
||||
wrong-secret cookie yields a fresh session instead of a hijack. `dream-cookie-sign` /
|
||||
`dream-cookie-unsign` (keyed hash; same not-cryptographic caveat — inject a host HMAC
|
||||
in production). Plain `dream-sessions` unchanged for the no-secret case.
|
||||
- **2026-06-07 — Ext: query/header convenience** (`lib/dream/types.sx`, types suite
|
||||
41→59, 358 total). `dream-queries`, `dream-query-param-or` / `dream-header-or` /
|
||||
`dream-param-or` (defaults), `dream-has-query?` / `-header?` / `-param?`,
|
||||
`dream-content-type-of`, `dream-method-is?`, `dream-accepts?` / `dream-wants-json?`
|
||||
(Accept-header content negotiation).
|
||||
- **2026-06-07 — Ext: api.sx facade + README** (`lib/dream/api.sx`, 9 tests, 367 total).
|
||||
`dream-version`, `dream-defaults` (pure stack: error-catch + content-type; logger is
|
||||
opt-in since it performs IO), `dream-make-app routes`, `dream-make-app-with`,
|
||||
`dream-serve`/`dream-serve-port`. `lib/dream/README.md` documents the full public
|
||||
surface, quickstart, the dependency-injection testing story, and caveats. **All
|
||||
planned extensions complete — 367/367 across 14 suites.**
|
||||
- **2026-06-07 — Ext: auth** (`lib/dream/auth.sx`, 23 tests, 390 total). Pure-SX base64
|
||||
codec (`dream-base64-encode`/`-decode`, arithmetic via `quotient`/`mod` — no bitwise),
|
||||
verified against RFC vectors (Man/Ma/M padding). `dream-basic-auth realm check` →
|
||||
401 + `WWW-Authenticate: Basic realm=…`, attaches `:dream-user` on success;
|
||||
`dream-basic-credentials` / `dream-authorization` accessors. `dream-require-bearer
|
||||
check` → attaches `:dream-principal` or 401; `dream-bearer-token` accessor.
|
||||
- **2026-06-07 — Ext: HTML escaping** (`lib/dream/html.sx`, 11 tests, 401 total).
|
||||
`dream-escape` (&/</>/"/' entities, ampersand first to avoid double-escape),
|
||||
`dream-attr`, `dream-escape-join`. Fixed a real **XSS hole** in the todo demo, which
|
||||
interpolated user text into `<li>` unescaped — now `(dream-escape (get it :text))`;
|
||||
regression test asserts `<script>` renders as `<script>`. 16 suites, 401/401.
|
||||
- **2026-06-07 — Ext: security headers + cache-control** (`lib/dream/headers.sx`, 12
|
||||
tests, 413 total). `dream-security-headers` middleware (X-Content-Type-Options
|
||||
nosniff, X-Frame-Options DENY, Referrer-Policy no-referrer; opt-in HSTS via
|
||||
`dream-security-headers-with`). Cache helpers `dream-cache`/`dream-private-cache`/
|
||||
`dream-no-store`/`dream-no-cache` + `dream-cache-for` middleware. **dream-on-sx is
|
||||
feature-complete: roadmap + 10 extensions, 413/413 across 17 suites. SATURATED —
|
||||
remaining work is host-on-sx's job to consume `dream-run` (don't edit hosts/).**
|
||||
|
||||
## Extensions (post-roadmap)
|
||||
|
||||
The five-types core is complete; these harden it toward a production HTTP front door.
|
||||
|
||||
- [x] **Router HTTP correctness**: 405 Method Not Allowed + `Allow` header; automatic
|
||||
HEAD (serve the GET handler with an empty body).
|
||||
- [x] **Status reason phrases** + `dream-status-text` (`lib/dream/error.sx`).
|
||||
- [x] **CORS middleware** (`dream-cors`).
|
||||
- [x] **Error-handling middleware** (`dream-catch` / custom 500 templates; `guard`-based).
|
||||
- [x] **Signed session cookies** (`dream-sessions-signed` — tamper-evident sid).
|
||||
- [x] **JSON helpers** (encode + recursive-descent parse, pure SX).
|
||||
- [x] **Query/header convenience** (`dream-queries`, `*-or` defaults, `dream-accepts?`).
|
||||
- [x] **`api.sx` facade + README** — `dream-make-app` / `dream-serve` + `README.md`.
|
||||
- [x] **Auth** — base64 (pure SX), HTTP Basic auth + Bearer-token middleware.
|
||||
- [x] **HTML escaping** (`dream-escape`/`dream-attr`) — fixed an XSS hole in the todo demo.
|
||||
- [x] **Security headers + cache-control** (`dream-security-headers`, `dream-cache`/`-no-store`).
|
||||
- [ ] **Static files:** `dream-static root-path` — serves files, ETags, range requests.
|
||||
- [ ] **`dream-run`**: wires root handler into SX's `perform (:http-listen ...)`.
|
||||
- [ ] **Demos** in `lib/dream/demos/`:
|
||||
- `hello.ml` → `lib/dream/demos/hello.sx`: "Hello, World!" route.
|
||||
- `counter.ml` → `lib/dream/demos/counter.sx`: in-memory counter with sessions.
|
||||
- `chat.ml` → `lib/dream/demos/chat.sx`: multi-room WebSocket chat.
|
||||
- `todo.ml` → `lib/dream/demos/todo.sx`: CRUD list with forms + CSRF.
|
||||
- [ ] Tests in `lib/dream/tests/`: routing dispatch, middleware composition, session round-trip, CSRF accept/reject, flash read-after-write — 60+ tests.
|
||||
|
||||
## Stdlib additions Dream will need
|
||||
|
||||
@@ -189,114 +104,8 @@ Confirm scope before starting; some of these may be addable as Dream-internal he
|
||||
|
||||
## Progress log
|
||||
|
||||
- **2026-06-07 — Core types** (`lib/dream/types.sx`, 41 tests). OCaml gate verified
|
||||
green (scoreboard 480/480, Phases 1–5 + Phase 6 stdlib). Dream is implemented in
|
||||
plain SX over the CEK — keywords are strings, so headers are dicts with lowercased
|
||||
string keys (`:content-type` == `"content-type"`). request (method/target/path/
|
||||
query/headers/body/params), response (status/headers/body), route records with
|
||||
constructors + accessors; smart response constructors (html/text/json/empty/
|
||||
not-found/redirect); `dream-coerce-response` wraps bare strings; query-string
|
||||
parsing. Conformance runner `lib/dream/conformance.sh` modelled on flow's.
|
||||
- **2026-06-07 — Router** (`lib/dream/router.sx`, 27 tests). `dream-get/post/put/
|
||||
delete/patch/head/options/any` route constructors; `dream-router` flattens routes
|
||||
(incl. nested scopes) and dispatches by method+path, first-match-wins, 404 on no
|
||||
match. Path matching is recursive over `/`-split segments: literal, `:name` binds
|
||||
a param, `**` catch-all binds remaining path under key `"**"`. Trailing slashes and
|
||||
query strings are ignored for routing. `dream-scope prefix mws routes` prepends the
|
||||
prefix and folds the middleware chain (`m1 @@ m2 @@ h`, first = outermost) onto each
|
||||
route's handler; nests correctly (inner mw innermost). Shared `dr/apply-middlewares`
|
||||
fold will back `dream-pipeline`.
|
||||
- **2026-06-07 — Middleware** (`lib/dream/middleware.sx`, 20 tests). `dream-pipeline`
|
||||
(reuses `dr/apply-middlewares`), `dream-no-middleware` identity. `dream-logger-with
|
||||
clock sink` is the testable core (records `{:method :path :status :elapsed}`);
|
||||
`dream-logger` wires it to `(perform (:dream-clock))` / `(perform (:dream-log …))`;
|
||||
`dream-log-line` formats one line. `dream-content-type` sniffs body (`<`→html,
|
||||
`{`/`[`→json, else text) only when the handler left Content-Type unset. Bonus
|
||||
`dream-set-header` and `dream-tap-request` combinators.
|
||||
- **2026-06-07 — Sessions** (`lib/dream/session.sx`, 30 tests). Solved the
|
||||
request→response mutation-visibility problem the way Dream does: the cookie carries
|
||||
only a session id; fields live in an injectable back-end store (the mapping table's
|
||||
`(perform (:session-get …))`). `dream-memory-sessions` is an in-memory store built
|
||||
on a `set!`-mutated captured `let` binding (no `ref`/`atom` in base env);
|
||||
`dream-perform-sessions` is the production back-end. `dream-sessions backend`
|
||||
middleware reads/creates the id, attaches `{:sid :io}` to the request, and emits a
|
||||
`Set-Cookie` (HttpOnly, SameSite=Lax) only for new sessions. Handler API:
|
||||
`dream-session-field` / `dream-set-session-field` / `dream-session-all` /
|
||||
`dream-invalidate-session` / `dream-session-id`. Also added shared cookie infra
|
||||
(`dr/parse-cookies`, `dream-cookie(s)`, `dr/build-cookie`, `dream-set-cookie`,
|
||||
`dream-resp-cookies`, `dream-drop-cookie`) — outgoing cookies accumulate in a
|
||||
`:set-cookies` list on the response so multiple Set-Cookie headers don't collide;
|
||||
reused by flash + CSRF. Full counter round-trip verified across three requests.
|
||||
- **2026-06-07 — Flash** (`lib/dream/flash.sx`, 14 tests). `dream-flash` middleware:
|
||||
decodes the incoming `dream.flash` cookie into the request, gives the handler a
|
||||
mutable outbox cell (`dr/flash-box`, the same `set!`-captured-`let` trick), then on
|
||||
response writes the outbox as a fresh flash cookie, or drops the cookie (Max-Age=0)
|
||||
when there were incoming messages but no new ones — so messages show exactly once.
|
||||
Handler API: `dream-add-flash-message` / `dream-flash-messages` (returns the
|
||||
PREVIOUS request's messages) / `dream-flash-of` (by category) / accessors. Cookie
|
||||
codec percent-escapes the `|`/`~`/`%` separators so categories/messages round-trip.
|
||||
Read-after-write verified across request boundaries incl. multi-category.
|
||||
- **2026-06-07 — Forms + CSRF (urlencoded)** (`lib/dream/form.sx`, 26 tests). Ok/Err
|
||||
result values (`dream-ok`/`dream-err` + predicates/accessors). `dream-form-fields`
|
||||
parses `application/x-www-form-urlencoded` with a full percent-decoder
|
||||
(`%XX` via `char-from-code`, `+`→space). CSRF is stateless + signed + session-
|
||||
scoped: token = `sid.signature`, verified by recomputing the signature and checking
|
||||
the session id — no server storage. Signing is **injectable** (`dream-csrf-with`);
|
||||
the default `dream-csrf-sign-default` is a pure-SX dual-base polynomial keyed hash
|
||||
(NOT cryptographic — production should inject a host HMAC). `dream-csrf` attaches
|
||||
context (needs the session middleware upstream for the sid); `dream-csrf-token` /
|
||||
`dream-csrf-tag` (hidden input for templates); `dream-form` returns `Ok fields` or
|
||||
`Err :csrf-token-invalid`; `dream-csrf-protect` auto-rejects unsafe methods (403)
|
||||
lacking a valid token. Full session→csrf→form stack verified accept + reject.
|
||||
Multipart deferred to the next commit.
|
||||
- **2026-06-07 — Multipart** (`lib/dream/form.sx` +9 tests, 35 total). `dream-multipart
|
||||
req` parses `multipart/form-data` into parts `{:name :filename :content-type
|
||||
:content}`, returns `Ok parts | Err :not-multipart`. Needed a substring splitter
|
||||
`dr/split-on` because the `split` primitive is **character-class** based (multi-char
|
||||
separators split on every char) — important gotcha. Boundary from the Content-Type
|
||||
(handles quoted form); segments filtered to those starting with CRLF; each split on
|
||||
the first `\r\n\r\n` into headers/content with one edge CRLF stripped (inner CRLFs
|
||||
in file content preserved). `dream-multipart-field` / `dream-multipart-file`
|
||||
accessors. In-memory, not streaming (noted for future). `\r`/`\n` string escapes
|
||||
work in SX literals.
|
||||
- **2026-06-07 — WebSockets** (`lib/dream/websocket.sx`, 16 tests). `dream-websocket
|
||||
handler` wraps a `(fn (ws) …)` into an ordinary handler returning a 101 upgrade
|
||||
response carrying the ws handler (`dream-websocket?` / `dream-ws-handler` for the
|
||||
host to detect + dispatch). `dream-send` / `dream-receive` / `dream-close` /
|
||||
`dream-ws-open?` / `dream-ws-broadcast` operate over an injectable io; production io
|
||||
is `(perform op)`, tests use `dream-mock-ws` (in-memory inbox/outbox/closed via the
|
||||
cell pattern) with `dream-ws-sent` / `dream-ws-closed?` introspection and
|
||||
`dream-ws-run` to drive a handler. Echo loop + room broadcast verified.
|
||||
- **2026-06-07 — Static files** (`lib/dream/static.sx`, 28 tests). `dream-static root`
|
||||
mounts at a `**` route and serves files: content-type by extension (mime map),
|
||||
weak ETag (`"hash-length"`) with `If-None-Match` → 304 (incl. `*`), and `Range:
|
||||
bytes=` requests → 206 with `Content-Range` (open-ended `bytes=N-` supported,
|
||||
unsatisfiable → 416). `..`/absolute path traversal → 403; missing → 404; full
|
||||
responses advertise `Accept-Ranges`. Filesystem is injectable —
|
||||
`dream-static-perform-fs` (host) vs `dream-memory-fs` (in-memory map for tests).
|
||||
- **2026-06-07 — dream-run** (`lib/dream/run.sx`, 20 tests). `dream-run handler`
|
||||
installs the root handler via `(perform (:http/listen {:port :host :app …}))` — no
|
||||
socket code, it wraps the existing server. `dream-app handler` is the adapter the
|
||||
host invokes per request: raw `{:method :target :headers :body}` → `dream-request`
|
||||
→ handler → serialised `{:status :headers :body :set-cookies}`, or a `{:status 101
|
||||
:websocket …}` upgrade. Bare-string handlers coerced; method defaults to GET;
|
||||
set-cookies (from session/flash) flow through. Listen transport injectable
|
||||
(`dream-run-with`) so the full wiring is tested with a mock that captures the op and
|
||||
re-runs the captured app. `dream-run-port` / `dream-run-opts` variants.
|
||||
- **2026-06-07 — Demos: hello + counter** (`lib/dream/demos/`, 10 tests). `hello.sx`
|
||||
is the canonical router with a `:name` param route. `counter.sx` is a per-session
|
||||
visit counter on the session middleware (+ a `/reset` POST that redirects),
|
||||
demonstrating session isolation across browsers. End-to-end tests drive both apps
|
||||
as the host would. chat (ws) + todo (forms+CSRF) next.
|
||||
- **2026-06-07 — Demos: chat + todo** (`lib/dream/demos/`, demos suite now 27 tests).
|
||||
`chat.sx` is a multi-room WebSocket chat over a room registry (join/leave/members/
|
||||
broadcast on the cell pattern); verified three clients see each other's broadcasts
|
||||
and a disconnect leaves the room. `todo.sx` is a CRUD list wiring session→csrf→
|
||||
router: add/toggle/delete go through `dream-form` (CSRF-guarded), an in-memory store
|
||||
holds items, pages render the list + `dream-csrf-tag`; verified the full
|
||||
add→render→toggle→delete cycle plus a 403 on a token-less POST. ws object equality
|
||||
is by reference, so the `:leave` filter removes exactly the right connection.
|
||||
_(awaiting activation conditions)_
|
||||
|
||||
## Blockers
|
||||
|
||||
_(none — gate green, loop active)_
|
||||
_(none yet — plan is cold)_
|
||||
|
||||
@@ -62,44 +62,73 @@ The novel substrate stress: equational matching. Pattern `X + Y` against `1 + 2
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — Parser + signatures
|
||||
- [ ] Parser for `fmod` / `endfm` syntax, sort declarations, op declarations, equations.
|
||||
- [ ] Sort hierarchy with subsort relations.
|
||||
- [ ] Operator overloading by arity + sort.
|
||||
- [ ] Tests: parse classic examples (peano nat, list of naturals).
|
||||
- [x] Parser for `fmod` / `endfm` syntax, sort declarations, op declarations, equations.
|
||||
- [x] Sort hierarchy with subsort relations.
|
||||
- [x] Operator overloading by arity + sort.
|
||||
- [x] Tests: parse classic examples (peano nat, list of naturals).
|
||||
|
||||
### Phase 2 — Syntactic equational reduction
|
||||
- [ ] Apply equations left-to-right until no equation matches.
|
||||
- [ ] Standard pattern matching (no equational theories yet — strict syntactic match).
|
||||
- [ ] Tests: peano arithmetic, list manipulation, propositional logic simplifier.
|
||||
- [x] Apply equations left-to-right until no equation matches.
|
||||
- [x] Standard pattern matching (no equational theories yet — strict syntactic match).
|
||||
- [x] Tests: peano arithmetic, list manipulation, propositional logic simplifier.
|
||||
|
||||
### Phase 3 — Equational matching (assoc / comm / id)
|
||||
- [ ] Extend matching to handle `assoc` operators (flatten then match across permutations of subterm groups).
|
||||
- [ ] Handle `comm` (try both argument orderings).
|
||||
- [ ] Handle `id: e` (X * e ≡ X).
|
||||
- [ ] Combinations: `assoc comm id` together.
|
||||
- [ ] Returns *all* matches, not just first — caller drives.
|
||||
- [ ] Tests: classic AC-matching examples (multiset rewriting, set theory, group equations).
|
||||
- [x] Extend matching to handle `assoc` operators (flatten then match across permutations of subterm groups).
|
||||
- [x] Handle `comm` (try both argument orderings).
|
||||
- [x] Handle `id: e` (X * e ≡ X).
|
||||
- [x] Combinations: `assoc comm id` together.
|
||||
- [x] Returns *all* matches, not just first — caller drives.
|
||||
- [x] Tests: classic AC-matching examples (multiset rewriting, set theory, group equations).
|
||||
|
||||
### Phase 4 — Conditional equations
|
||||
- [ ] `ceq L = R if Cond` — apply only when `Cond` reduces to true.
|
||||
- [ ] Recursion via the same reduce engine (terminating because Cond is shorter).
|
||||
- [ ] Tests: gcd, sorting, conditional simplifications.
|
||||
- [x] `ceq L = R if Cond` — apply only when `Cond` reduces to true.
|
||||
- [x] Recursion via the same reduce engine (terminating because Cond is shorter).
|
||||
- [x] Tests: gcd, sorting, conditional simplifications.
|
||||
|
||||
### Phase 5 — System modules + rewrite rules
|
||||
- [ ] `mod ... endm` syntax with `rl` rules.
|
||||
- [ ] Rules apply asymmetrically (`=>` not `=`); fairness across rules.
|
||||
- [ ] Default strategy: top-down, leftmost-outermost, first applicable rule.
|
||||
- [ ] Tests: state-transition systems (puzzle solvers, protocol simulators).
|
||||
- [x] `mod ... endm` syntax with `rl` rules.
|
||||
- [x] Rules apply asymmetrically (`=>` not `=`); fairness across rules.
|
||||
- [x] Default strategy: top-down, leftmost-outermost, first applicable rule.
|
||||
- [x] Tests: state-transition systems (puzzle solvers, protocol simulators).
|
||||
|
||||
### Phase 6 — Strategy language
|
||||
- [ ] Compose strategies: sequential `;`, alternative `|`, iteration `*`, fixed-point.
|
||||
- [ ] User-named strategies; strategy expressions as values.
|
||||
- [ ] Tests: programs whose meaning depends on strategy choice.
|
||||
- [x] Compose strategies: sequential `;`, alternative `|`, iteration `*`, fixed-point.
|
||||
- [x] User-named strategies; strategy expressions as values.
|
||||
- [x] Tests: programs whose meaning depends on strategy choice.
|
||||
|
||||
### Phase 7 — Reflection (META-LEVEL)
|
||||
- [ ] Terms-as-data: `META-LEVEL` lets you encode/decode terms as Maude terms.
|
||||
- [ ] Build proofs / programs that manipulate Maude programs.
|
||||
- [ ] Tests: meta-circular interpretation, generic theorem helpers.
|
||||
- [x] Terms-as-data: `META-LEVEL` lets you encode/decode terms as Maude terms.
|
||||
- [x] Build proofs / programs that manipulate Maude programs.
|
||||
- [x] Tests: meta-circular interpretation, generic theorem helpers.
|
||||
|
||||
### Extensions (post-roadmap, toward the end-state goal)
|
||||
- [x] Mixfix surface-syntax printer (`lib/maude/pretty.sx`) — `mau/term->maude`
|
||||
renders the internal prefix form back as Maude mixfix (`((s X) + 0)`),
|
||||
driven by op forms; `mau/red->maude` / `mau/rew->maude`. 11 tests.
|
||||
- [x] Program runner (`lib/maude/run.sx`) — `mau/run-program` / `mau/run` parse
|
||||
a module plus trailing `reduce`/`red`/`rewrite`/`rew TERM .` commands
|
||||
(`... in MOD : TERM` qualifier accepted) and execute them, rendering results
|
||||
in surface syntax. Runs an idiomatic `.maude` file end-to-end. Now also:
|
||||
`search START =>* GOAL .` command (reports the path), least-sort annotated
|
||||
output via `mau/run-pretty` → `result SORT: TERM` (Maude-style). 10 tests.
|
||||
- [x] Witness-path search (`lib/maude/searchpath.sx`) — `mau/search-path` /
|
||||
`mau/search-length` return the shortest sequence of states start..goal (the
|
||||
solution moves), not just yes/no. 8 tests.
|
||||
- [x] Order-sorted least-sort inference (`lib/maude/sorts.sx`) — `mau/term-sort`
|
||||
computes the least sort of a term: the smallest result sort among the op
|
||||
declarations whose argument sorts the actual args satisfy (modulo subsorting),
|
||||
so an overloaded `f(1)` is `NzNat` but `f(s 0)` is `Nat`. `mau/has-sort?`
|
||||
for membership-style checks. Answers the plan's substrate question — order-
|
||||
sorted signatures fit cleanly. 14 tests.
|
||||
- [x] `gather` / parse-time associativity — infix ops parse left (default,
|
||||
`(E e)`) or right (`(e E)`) per the gather attr, so cons `_:_ [gather (e E)]`
|
||||
reads `a : b : c` as right-nested. Full insertion sort now runs over BARE cons
|
||||
lists (no parens). 7 tests.
|
||||
- [x] `owise` equations — parser now reads trailing eq attributes
|
||||
(`eq L = R [owise] .`), `mau/split-attrs`; `mau/crewrite-top` is two-pass
|
||||
(ordinary equations first, owise last), so an owise catch-all fires only when
|
||||
nothing else applies, regardless of declaration order. Parser also reads
|
||||
`label`/`prec`/`owise`/`id:` eq+op attrs. 8 tests.
|
||||
|
||||
### Phase 8 — Propose `lib/guest/rewriting/`
|
||||
- [ ] Extract equational matching engine (the most reusable piece).
|
||||
@@ -107,6 +136,49 @@ The novel substrate stress: equational matching. Pattern `X + Y` against `1 + 2
|
||||
- [ ] Extract strategy combinators.
|
||||
- [ ] Wait for second consumer before extracting.
|
||||
|
||||
**Status: BLOCKED — no second consumer yet.** The reusable core is identified:
|
||||
`lib/maude/matching.sx` (AC matching + canon) + `lib/maude/fire.sx`
|
||||
(short-circuit firing) are the prime extraction candidates; `lib/maude/strategy.sx`
|
||||
(combinators) is the third. Keep them separable. Do not extract until a Pure/
|
||||
CafeOBJ/term-rewriting playground consumer appears (or artdag-on-sx's effect
|
||||
optimiser, per the chisel note).
|
||||
|
||||
### SATURATION (post-roadmap)
|
||||
|
||||
All 7 roadmap phases + 7 extensions (pretty / run / search-path / owise /
|
||||
gather / order-sorted least-sort / search-command + result-sort) DONE, **254/254
|
||||
across 13 suites.** The end-state goal — a faithful Maude 3 functional+system
|
||||
core that runs idiomatic programs and proves equational identities — is met:
|
||||
sorts/subsorts/overloading, equational reduction modulo assoc/comm/id,
|
||||
conditional eqs + owise, system rules (rew + BFS search with witness paths),
|
||||
a strategy language, and META-LEVEL reflection, with a mixfix surface printer
|
||||
and an end-to-end `.maude` runner (reduce/rewrite/search commands, sort-annotated
|
||||
output). **artdag-on-sx fit prototype (lib/maude/tests/effects.sx, 8 tests):** artdag's
|
||||
optimise passes — adjacent-op fusion, no-op/dead-op elim, identity elim,
|
||||
CSE/idempotent dedup — expressed as `eq`s; the optimised pipeline IS the normal
|
||||
form, and confluence ⇒ a stable content id. This is the "second consumer"
|
||||
spike: it justifies a maude-driven optimiser in `lib/artdag` and the eventual
|
||||
`lib/guest/rewriting/` extraction. Faithfulness note surfaced: `id:` only
|
||||
affects matching/canon, NOT auto-reduction — write explicit identity eqs (or
|
||||
read off the canonical form) if you need `0 + N` to reduce in the term itself.
|
||||
|
||||
**Confluence / critical-pair checking (lib/maude/confluence.sx, 12 tests):**
|
||||
`mau/confluent?` answers the plan's substrate question "can confluence be
|
||||
checked." Two-sided syntactic unification (`mau/u-unify`, with occurs check) →
|
||||
critical pairs from LHS overlaps (`mau/critical-pairs`) → joinability via
|
||||
`mau/ac-equal?` of the normal forms (`mau/non-joinable-pairs` gives the
|
||||
diagnostics, `mau/cp->str` renders `left <?> right`). Caught `f(a)=b, a=c` as
|
||||
non-confluent (`b <?> f(c)`); confirmed peano/idempotent/AC examples confluent.
|
||||
SCOPE: unification is SYNTACTIC — exact for free/constructor ops, an
|
||||
under-approximation for AC overlaps (full AC-unification is NP/infinitary, out
|
||||
of scope), but joinability uses the AC-canonical form so AC laws still join
|
||||
correctly. This is the CID-stability oracle for the artdag optimiser: an
|
||||
optimisation rule set is content-id-stable iff `mau/confluent?` holds.
|
||||
|
||||
Pacing down to hardening. Possible niche future work: membership
|
||||
axioms (`mb`/`cmb`), critical-pair / confluence checking, meta-search, full
|
||||
mixfix (multi-`_` ops, juxtaposition `__`).
|
||||
|
||||
## lib/guest feedback loop
|
||||
|
||||
**Consumes:** `core/lex`, `core/pratt`, `core/ast`, `core/match` (with proposed extension for equational matching).
|
||||
@@ -125,7 +197,129 @@ The novel substrate stress: equational matching. Pattern `X + Y` against `1 + 2
|
||||
- Pure language (Albrecht Gräf): https://agraef.github.io/pure-lang/ — practical functional rewriting.
|
||||
|
||||
## Progress log
|
||||
_(awaiting Phase 1 — depends on substrate matching maturity from lib/guest/core/match.sx)_
|
||||
|
||||
- **Phase 1 (parser + signatures) — DONE, 65/65.** `lib/maude/term.sx` (term
|
||||
repr: var/app dicts, equality, vars, `term->str`) + `lib/maude/parser.sx`
|
||||
(whitespace+bracket tokenizer with `---`/`***` comments; mixfix
|
||||
classification by splitting op names on `_`; precedence-climbing term parser
|
||||
over a pratt table built from op decls; `fmod`/`mod` modules with
|
||||
sorts/subsorts/ops/vars/eqs/rules). Consumes `lib/guest/lex.sx` (ws classes)
|
||||
and `lib/guest/pratt.sx` (op-table lookup). Verified on Peano (`s X + Y`
|
||||
parses `_+_(s_(X), Y)` — prefix binds tighter than infix) and NatList
|
||||
(transitive subsorts NzNat<Nat<List; `_;_` overloaded; `id: nil` / `prec`
|
||||
attrs). ceq/rl/crl parsed structurally (cond split on `if`, label in `[..]`).
|
||||
Suite + conformance driver wired (`lib/maude/conformance.{conf,sh}`, MODE=dict).
|
||||
- Notes for next phases: terms are `{:t :app :op N :args (...)}` /
|
||||
`{:t :var :name N :sort S}`; module carries a `:grammar` so
|
||||
`mau/parse-term-in` can parse term strings against its op table. Overloading
|
||||
is recorded but NOT resolved at parse time (resolve at reduce time).
|
||||
|
||||
- **Phase 2 (syntactic reduction) — DONE, 91/91 total.** `lib/maude/reduce.sx`:
|
||||
one-sided syntactic matching (`mau/match` — pattern vars only, non-linear
|
||||
patterns checked by bound-var equality), immutable substitutions via `assoc`,
|
||||
`mau/subst-apply`, top rewrite `mau/rewrite-top` (first unconditional eq whose
|
||||
LHS matches; conditional eqs skipped until Phase 4), innermost normalisation
|
||||
to a fixpoint `mau/normalize` (args normalised before the operator; fuel-
|
||||
guarded). API: `mau/reduce` / `mau/reduce-term` / `mau/reduce->str`. Tested on
|
||||
Peano (+,*), list ops (append/length/rev), a propositional simplifier, and
|
||||
non-linear `same(X,X)`. Innermost is fine for confluent terminating eq sets;
|
||||
Phase 3 will replace the matcher with AC-aware matching (multi-valued).
|
||||
|
||||
- **Phase 3 (matching modulo assoc/comm/id) — DONE, 119/119 total. THE CHISEL.**
|
||||
`lib/maude/matching.sx`. `mau/mm` is the multi-valued matcher (returns the
|
||||
full list of substitutions): free=positional, comm=both orderings,
|
||||
assoc=flatten f-spine + ordered sequence match (vars grab contiguous blocks),
|
||||
assoc+comm=multiset match (vars grab sub-multisets via `mau/all-splits` =
|
||||
2^n subset/complement pairs). `id: e` lets a var grab the empty block
|
||||
(contributing e); `mau/var-kmin` gives kmin 0 under id. `mau/canon` is the
|
||||
AC-canonical printout (flatten, drop identities, sort comm args) and powers
|
||||
`mau/ac-equal?` (used for bound-var checks too). AC *rewriting* extends each
|
||||
f-AC equation l=r with rest vars — comm: `f(l,$R)`; assoc: `f($L,l,$R)` —
|
||||
so a rule fires on any sub-multiset/subword (`$`-prefixed rest vars allowed
|
||||
empty). `mau/first-change` walks candidate matches and only commits a rewrite
|
||||
that changes the canonical form — this is what makes idempotency (`X U X = X`)
|
||||
and identity-absorbing matches terminate. API: `mau/ac-reduce` /
|
||||
`mau/ac-reduce->str` / `mau/ac-canon` / `mau/match-all`. Verified: AC match
|
||||
counts (X+Y vs a+b+c = 6), bag collapse, set dedup with empty, group
|
||||
cancellation (assoc non-comm + inverse).
|
||||
- Notes for next phases: AC matching is multi-valued — Phase 5 rule
|
||||
application should iterate ALL of `mau/mm`'s results, not just first. The
|
||||
`mau/ac-rewrite-eq` extension trick (rest vars) is the reusable core for
|
||||
a future `lib/guest/rewriting/` (Phase 8). Keep `mau/canon` as the equality
|
||||
oracle. `$EMPTY` is a transient marker for empty rest blocks w/o id; never
|
||||
leaks past `mau/restv`.
|
||||
|
||||
- **Phase 4 (conditional equations) — DONE, 138/138 total.**
|
||||
`lib/maude/conditional.sx` is a condition-aware superset of the Phase 3
|
||||
reducer. `mau/eq-candidates` enumerates (subst, result) pairs for an
|
||||
equation (AC via rest-var extension `mau/ac-candidates`, else `mau/mm`);
|
||||
`mau/try-candidates` commits the first candidate that both makes progress
|
||||
(canonical form changes) AND whose guard holds. `mau/cond-holds?` evaluates
|
||||
`{:kind :eq}` guards (reduce both sides, `ac-equal?`) and `{:kind :bool}`
|
||||
guards (reduce, `=AC= true`), recursing through `mau/cnormalize` — same
|
||||
reducer, so guards can mention other (conditional) equations. Public:
|
||||
`mau/creduce` / `mau/creduce->str` / `mau/ccanon`. Verified on gcd
|
||||
(subtractive, recursive guard), insertion sort (true/false branches), max,
|
||||
and even (bool-kind `if pred` guard).
|
||||
- Notes for next phases: `mau/creduce` is the canonical reducer now; Phase 5
|
||||
rules reduce to normal form via creduce between rewrite steps. `_:_` cons
|
||||
parses LEFT-assoc (no `gather` support yet) — write list literals
|
||||
right-parenthesized, or add a `gather`/parse-assoc attr later if a test
|
||||
needs bare `a : b : c`.
|
||||
|
||||
- **Phase 5 (system modules + rewrite rules) — DONE, 159/159 total.**
|
||||
`lib/maude/rewrite.sx` + `lib/maude/fire.sx`. Rules (rl/crl) reuse the
|
||||
equation firing machinery (a rule dict is shaped like an eq). `mau/rewrite`
|
||||
is the default strategy: normalise with eqs (`creduce`), fire ONE rule
|
||||
top-down/leftmost-outermost/first-applicable, renormalise, repeat (bounded
|
||||
by fuel). `mau/rew m src n` = bounded `rew [n]`. `mau/search` is BFS over
|
||||
ALL one-step successors (`mau/all-successors`) for reachability — solves the
|
||||
branching `goal` reachable only off the path `rew` takes. Verified: AC
|
||||
multiset coin-change (rule on a sub-multiset), cyclic traffic light (bounded),
|
||||
branching nondeterminism (rew vs search), conditional `crl` clock, eq/rule
|
||||
interleaving.
|
||||
- **PERF (important):** `lib/maude/fire.sx` is the short-circuiting matcher —
|
||||
`mau/fire-eq` finds the FIRST productive match via predicate-threaded
|
||||
`mau/ms-find`/`mau/seq-find` instead of materialising the whole solution
|
||||
set. Without it, AC rewriting on N identical elements is exponential
|
||||
(`q;q;q;q;q;q;q;q` went 60s+ → <1s). The eager `mau/match-multiset` /
|
||||
`mau/eq-candidates` are kept ONLY for `mau/match-all` and `search` (which
|
||||
truly need every solution). Phase 4 `creduce` and Phase 5 rules both fire
|
||||
via `mau/fire-eq`. Keep this split: never route single-step rewriting
|
||||
through the eager enumerator.
|
||||
- Notes: juxtaposition `__` (empty-token mixfix) and `gather` are NOT parsed —
|
||||
use an explicit infix op for multisets and right-parenthesise list literals.
|
||||
`.` can't be an op token (statement terminator). `mau/search` is the prime
|
||||
Phase 7 reflection / Phase 8 extraction target alongside the matcher.
|
||||
|
||||
- **Phase 6 (strategy language) — DONE, 178/178 total.**
|
||||
`lib/maude/strategy.sx`. Strategies are first-class tagged-dict VALUES and
|
||||
set-valued: `mau/sapply ctx strat term` → deduped (by canon) list of results.
|
||||
Combinators: `idle`/`fail`/`all`/`rule LABEL`/`seq`/`alt`/`star`/`plus`/`bang`
|
||||
/`name`. `seq` = flatmap B over A's results; `alt` = union; `star` = reflexive-
|
||||
transitive closure (BFS, canon-deduped); `plus` = A then star; `bang` =
|
||||
normal forms (reachable terms where A yields nothing). Named strategies via a
|
||||
NAME->strategy env dict passed to `mau/srun`/`mau/srun-canon`. Verified that
|
||||
the same rule set computes different things under different strategies
|
||||
(single rule vs all vs seq order vs alt vs star vs bang). Built on Phase 5
|
||||
`mau/all-successors` (rule label filter = `mau/rules-with-label`).
|
||||
- Note: `dict-set!` returns the value, not the dict — build a named-strategy
|
||||
env by binding `(define env {})` then `(dict-set! env ...)`, pass `env`.
|
||||
`srun-canon` sorts results so expected lists must be sorted.
|
||||
|
||||
- **Phase 7 (reflection / META-LEVEL) — DONE, 196/196 total.**
|
||||
`lib/maude/meta.sx`. `mau/up-term` re-encodes an object term as a term built
|
||||
from meta-constructors `mt-var`(name,sort) / `mt-app`(op, args...) — a
|
||||
represented term is itself a first-class object term you can build, inspect,
|
||||
transform. `mau/down-term` reverses (round-trips). Reflective ops:
|
||||
`mau/meta-reduce` / `mau/meta-rewrite` / `mau/meta-apply LABEL` take and
|
||||
return represented terms. `mau/meta-circular?` verifies the law
|
||||
`down(metaReduce(up t)) =AC= reduce t` (reflection agrees with the object
|
||||
level). `mau/meta-prove-equal?` is a generic equational theorem helper
|
||||
(prove an identity by joint reduction). Verified: up/down round-trip,
|
||||
meta-reduce returns a represented normal form, meta-circular law on Peano,
|
||||
meta-apply of a single rule, commutativity/associativity instance proofs,
|
||||
and building a program at the meta level then running it.
|
||||
|
||||
## Blockers
|
||||
_(speculative — equational matching is algorithmically heavy and may surface JIT issues)_
|
||||
_(none)_
|
||||
|
||||
Reference in New Issue
Block a user