Compare commits
17 Commits
loops/hask
...
loops/erla
| Author | SHA1 | Date | |
|---|---|---|---|
| c363856df6 | |||
| aa7d691028 | |||
| 089e2569d4 | |||
| 1516e1f9cd | |||
| 51ba2da119 | |||
| 8a8d0e14bd | |||
| 0962e4231c | |||
| 2a3340f8e1 | |||
| 97513e5b96 | |||
| e2e801e38a | |||
| d191f7cd9e | |||
| 266693a2f6 | |||
| bc1a69925e | |||
| 1dc96c814e | |||
| 7f4fb9c3ed | |||
| 4965be71ca | |||
| efbab24cb2 |
86
lib/erlang/bench_ring.sh
Executable file
86
lib/erlang/bench_ring.sh
Executable file
@@ -0,0 +1,86 @@
|
||||
#!/usr/bin/env bash
|
||||
# Erlang-on-SX ring benchmark.
|
||||
#
|
||||
# Spawns N processes in a ring, passes a token N hops (one full round),
|
||||
# and reports wall-clock time + throughput. Aspirational target from
|
||||
# the plan is 1M processes; current sync-scheduler architecture caps out
|
||||
# orders of magnitude lower — this script measures honestly across a
|
||||
# range of N so the result/scaling is recorded.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/erlang/bench_ring.sh # default ladder
|
||||
# bash lib/erlang/bench_ring.sh 100 1000 5000 # custom Ns
|
||||
|
||||
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
|
||||
|
||||
if [ "$#" -gt 0 ]; then
|
||||
NS=("$@")
|
||||
else
|
||||
NS=(10 100 500 1000)
|
||||
fi
|
||||
|
||||
TMPFILE=$(mktemp)
|
||||
trap "rm -f $TMPFILE" EXIT
|
||||
|
||||
# One-line Erlang program. Replaces __N__ with the size for each run.
|
||||
PROGRAM='Me = self(), N = __N__, Spawner = fun () -> receive {setup, Next} -> Loop = fun () -> receive {token, 0, Parent} -> Parent ! done; {token, K, Parent} -> Next ! {token, K-1, Parent}, Loop() end end, Loop() end end, BuildRing = fun (K, Acc) -> if K =:= 0 -> Acc; true -> BuildRing(K-1, [spawn(Spawner) | Acc]) end end, Pids = BuildRing(N, []), Wire = fun (Ps) -> case Ps of [P, Q | _] -> P ! {setup, Q}, Wire(tl(Ps)); [Last] -> Last ! {setup, hd(Pids)} end end, Wire(Pids), hd(Pids) ! {token, N, Me}, receive done -> done end'
|
||||
|
||||
run_n() {
|
||||
local n="$1"
|
||||
local prog="${PROGRAM//__N__/$n}"
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/erlang/tokenizer.sx")
|
||||
(load "lib/erlang/parser.sx")
|
||||
(load "lib/erlang/parser-core.sx")
|
||||
(load "lib/erlang/parser-expr.sx")
|
||||
(load "lib/erlang/parser-module.sx")
|
||||
(load "lib/erlang/transpile.sx")
|
||||
(load "lib/erlang/runtime.sx")
|
||||
(epoch 2)
|
||||
(eval "(erlang-eval-ast \"${prog//\"/\\\"}\")")
|
||||
EPOCHS
|
||||
|
||||
local start_s start_ns end_s end_ns elapsed_ms
|
||||
start_s=$(date +%s)
|
||||
start_ns=$(date +%N)
|
||||
out=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
end_s=$(date +%s)
|
||||
end_ns=$(date +%N)
|
||||
|
||||
local ok="false"
|
||||
if echo "$out" | grep -q ':name "done"'; then ok="true"; fi
|
||||
|
||||
# ms = (end_s - start_s)*1000 + (end_ns - start_ns)/1e6
|
||||
elapsed_ms=$(awk -v s1="$start_s" -v n1="$start_ns" -v s2="$end_s" -v n2="$end_ns" \
|
||||
'BEGIN { printf "%d", (s2 - s1) * 1000 + (n2 - n1) / 1000000 }')
|
||||
|
||||
if [ "$ok" = "true" ]; then
|
||||
local hops_per_s
|
||||
hops_per_s=$(awk -v n="$n" -v ms="$elapsed_ms" \
|
||||
'BEGIN { if (ms == 0) ms = 1; printf "%.0f", n * 1000 / ms }')
|
||||
printf " N=%-8s hops=%-8s %sms (%s hops/s)\n" "$n" "$n" "$elapsed_ms" "$hops_per_s"
|
||||
else
|
||||
printf " N=%-8s FAILED %sms\n" "$n" "$elapsed_ms"
|
||||
fi
|
||||
}
|
||||
|
||||
echo "Ring benchmark — sx_server.exe (synchronous scheduler)"
|
||||
echo
|
||||
for n in "${NS[@]}"; do
|
||||
run_n "$n"
|
||||
done
|
||||
echo
|
||||
echo "Note: 1M-process target from the plan is aspirational; the synchronous"
|
||||
echo "scheduler with shift-based suspension and dict-based env copies is not"
|
||||
echo "engineered for that scale. Numbers above are honest baselines."
|
||||
35
lib/erlang/bench_ring_results.md
Normal file
35
lib/erlang/bench_ring_results.md
Normal file
@@ -0,0 +1,35 @@
|
||||
# Ring Benchmark Results
|
||||
|
||||
Generated by `lib/erlang/bench_ring.sh` against `sx_server.exe` on the
|
||||
synchronous Erlang-on-SX scheduler.
|
||||
|
||||
| N (processes) | Hops | Wall-clock | Throughput |
|
||||
|---|---|---|---|
|
||||
| 10 | 10 | 907ms | 11 hops/s |
|
||||
| 50 | 50 | 2107ms | 24 hops/s |
|
||||
| 100 | 100 | 3827ms | 26 hops/s |
|
||||
| 500 | 500 | 17004ms | 29 hops/s |
|
||||
| 1000 | 1000 | 29832ms | 34 hops/s |
|
||||
|
||||
(Each `Nm` row spawns N processes connected in a ring and passes a
|
||||
single token N hops total — i.e. the token completes one full lap.)
|
||||
|
||||
## Status of the 1M-process target
|
||||
|
||||
Phase 3's stretch goal in `plans/erlang-on-sx.md` is a million-process
|
||||
ring benchmark. **That target is not met** in the current synchronous
|
||||
scheduler; extrapolating from the table above, 1M hops would take
|
||||
~30 000 s. Correctness is fine — the program runs at every measured
|
||||
size — but throughput is bound by per-hop overhead.
|
||||
|
||||
Per-hop cost is dominated by:
|
||||
- `er-env-copy` per fun clause attempt (whole-dict copy each time)
|
||||
- `call/cc` capture + `raise`/`guard` unwind on every `receive`
|
||||
- `er-q-delete-at!` rebuilds the mailbox backing list on every match
|
||||
- `dict-set!`/`dict-has?` lookups in the global processes table
|
||||
|
||||
To reach 1M-process throughput in this architecture would need at
|
||||
least: persistent (path-copying) envs, an inline scheduler that
|
||||
doesn't call/cc on the common path (msg-already-in-mailbox), and a
|
||||
linked-list mailbox. None of those are in scope for the Phase 3
|
||||
checkbox — captured here as the floor we're starting from.
|
||||
153
lib/erlang/conformance.sh
Executable file
153
lib/erlang/conformance.sh
Executable file
@@ -0,0 +1,153 @@
|
||||
#!/usr/bin/env bash
|
||||
# Erlang-on-SX conformance runner.
|
||||
#
|
||||
# Loads every erlang test suite via the epoch protocol, collects
|
||||
# pass/fail counts, and writes lib/erlang/scoreboard.json + .md.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/erlang/conformance.sh # run all suites
|
||||
# bash lib/erlang/conformance.sh -v # verbose per-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:-}"
|
||||
TMPFILE=$(mktemp)
|
||||
OUTFILE=$(mktemp)
|
||||
trap "rm -f $TMPFILE $OUTFILE" EXIT
|
||||
|
||||
# Each suite: name | counter pass | counter total
|
||||
SUITES=(
|
||||
"tokenize|er-test-pass|er-test-count"
|
||||
"parse|er-parse-test-pass|er-parse-test-count"
|
||||
"eval|er-eval-test-pass|er-eval-test-count"
|
||||
"runtime|er-rt-test-pass|er-rt-test-count"
|
||||
"ring|er-ring-test-pass|er-ring-test-count"
|
||||
"ping-pong|er-pp-test-pass|er-pp-test-count"
|
||||
"bank|er-bank-test-pass|er-bank-test-count"
|
||||
"echo|er-echo-test-pass|er-echo-test-count"
|
||||
"fib|er-fib-test-pass|er-fib-test-count"
|
||||
)
|
||||
|
||||
cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 1)
|
||||
(load "lib/erlang/tokenizer.sx")
|
||||
(load "lib/erlang/parser.sx")
|
||||
(load "lib/erlang/parser-core.sx")
|
||||
(load "lib/erlang/parser-expr.sx")
|
||||
(load "lib/erlang/parser-module.sx")
|
||||
(load "lib/erlang/transpile.sx")
|
||||
(load "lib/erlang/runtime.sx")
|
||||
(load "lib/erlang/tests/tokenize.sx")
|
||||
(load "lib/erlang/tests/parse.sx")
|
||||
(load "lib/erlang/tests/eval.sx")
|
||||
(load "lib/erlang/tests/runtime.sx")
|
||||
(load "lib/erlang/tests/programs/ring.sx")
|
||||
(load "lib/erlang/tests/programs/ping_pong.sx")
|
||||
(load "lib/erlang/tests/programs/bank.sx")
|
||||
(load "lib/erlang/tests/programs/echo.sx")
|
||||
(load "lib/erlang/tests/programs/fib_server.sx")
|
||||
(epoch 100)
|
||||
(eval "(list er-test-pass er-test-count)")
|
||||
(epoch 101)
|
||||
(eval "(list er-parse-test-pass er-parse-test-count)")
|
||||
(epoch 102)
|
||||
(eval "(list er-eval-test-pass er-eval-test-count)")
|
||||
(epoch 103)
|
||||
(eval "(list er-rt-test-pass er-rt-test-count)")
|
||||
(epoch 104)
|
||||
(eval "(list er-ring-test-pass er-ring-test-count)")
|
||||
(epoch 105)
|
||||
(eval "(list er-pp-test-pass er-pp-test-count)")
|
||||
(epoch 106)
|
||||
(eval "(list er-bank-test-pass er-bank-test-count)")
|
||||
(epoch 107)
|
||||
(eval "(list er-echo-test-pass er-echo-test-count)")
|
||||
(epoch 108)
|
||||
(eval "(list er-fib-test-pass er-fib-test-count)")
|
||||
EPOCHS
|
||||
|
||||
timeout 120 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
|
||||
# Parse "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
|
||||
parse_pair() {
|
||||
local epoch="$1"
|
||||
local line
|
||||
line=$(grep -A1 "^(ok-len $epoch " "$OUTFILE" | tail -1)
|
||||
echo "$line" | sed -E 's/[()]//g'
|
||||
}
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_COUNT=0
|
||||
JSON_SUITES=""
|
||||
MD_ROWS=""
|
||||
|
||||
idx=0
|
||||
for entry in "${SUITES[@]}"; do
|
||||
name="${entry%%|*}"
|
||||
epoch=$((100 + idx))
|
||||
pair=$(parse_pair "$epoch")
|
||||
pass=$(echo "$pair" | awk '{print $1}')
|
||||
count=$(echo "$pair" | awk '{print $2}')
|
||||
if [ -z "$pass" ] || [ -z "$count" ]; then
|
||||
pass=0
|
||||
count=0
|
||||
fi
|
||||
TOTAL_PASS=$((TOTAL_PASS + pass))
|
||||
TOTAL_COUNT=$((TOTAL_COUNT + count))
|
||||
status="ok"
|
||||
marker="✅"
|
||||
if [ "$pass" != "$count" ]; then
|
||||
status="fail"
|
||||
marker="❌"
|
||||
fi
|
||||
if [ "$VERBOSE" = "-v" ]; then
|
||||
printf " %-12s %s/%s\n" "$name" "$pass" "$count"
|
||||
fi
|
||||
if [ -n "$JSON_SUITES" ]; then JSON_SUITES+=","; fi
|
||||
JSON_SUITES+=$'\n '
|
||||
JSON_SUITES+="{\"name\":\"$name\",\"pass\":$pass,\"total\":$count,\"status\":\"$status\"}"
|
||||
MD_ROWS+="| $marker | $name | $pass | $count |"$'\n'
|
||||
idx=$((idx + 1))
|
||||
done
|
||||
|
||||
printf '\nErlang-on-SX conformance: %d / %d\n' "$TOTAL_PASS" "$TOTAL_COUNT"
|
||||
|
||||
# scoreboard.json
|
||||
cat > lib/erlang/scoreboard.json <<JSON
|
||||
{
|
||||
"language": "erlang",
|
||||
"total_pass": $TOTAL_PASS,
|
||||
"total": $TOTAL_COUNT,
|
||||
"suites": [$JSON_SUITES
|
||||
]
|
||||
}
|
||||
JSON
|
||||
|
||||
# scoreboard.md
|
||||
cat > lib/erlang/scoreboard.md <<MD
|
||||
# Erlang-on-SX Scoreboard
|
||||
|
||||
**Total: ${TOTAL_PASS} / ${TOTAL_COUNT} tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
$MD_ROWS
|
||||
|
||||
Generated by \`lib/erlang/conformance.sh\`.
|
||||
MD
|
||||
|
||||
if [ "$TOTAL_PASS" -eq "$TOTAL_COUNT" ]; then
|
||||
exit 0
|
||||
else
|
||||
exit 1
|
||||
fi
|
||||
587
lib/erlang/runtime.sx
Normal file
587
lib/erlang/runtime.sx
Normal file
@@ -0,0 +1,587 @@
|
||||
;; Erlang runtime — scheduler, process records, mailbox queue.
|
||||
;; Phase 3 foundation. spawn/send/receive build on these primitives.
|
||||
;;
|
||||
;; Scheduler is a single global dict in `er-scheduler` holding:
|
||||
;; :next-pid INT — counter for fresh pid allocation
|
||||
;; :processes DICT — pid-key (string) -> process record
|
||||
;; :runnable QUEUE — FIFO of pids ready to run
|
||||
;; :current PID — pid currently executing, or nil
|
||||
;;
|
||||
;; A pid value is tagged: {:tag "pid" :id INT}. Pids compare by id.
|
||||
;;
|
||||
;; Process record fields:
|
||||
;; :pid — this process's pid
|
||||
;; :mailbox — queue of received messages (arrival order)
|
||||
;; :state — "runnable" | "running" | "waiting" | "exiting" | "dead"
|
||||
;; :continuation — saved k (for receive suspension); nil otherwise
|
||||
;; :receive-pats — patterns the process is blocked on; nil otherwise
|
||||
;; :trap-exit — bool
|
||||
;; :links — list of pids
|
||||
;; :monitors — list of {:ref :pid}
|
||||
;; :env — Erlang env at the last yield
|
||||
;; :exit-reason — nil until the process exits
|
||||
;;
|
||||
;; Queue — amortised-O(1) FIFO with head-pointer + slab-compact:
|
||||
;; {:items (list...) :head-idx INT}
|
||||
|
||||
;; ── queue ────────────────────────────────────────────────────────
|
||||
(define er-q-new (fn () {:head-idx 0 :items (list)}))
|
||||
|
||||
(define er-q-push! (fn (q x) (append! (get q :items) x)))
|
||||
|
||||
(define
|
||||
er-q-pop!
|
||||
(fn
|
||||
(q)
|
||||
(let
|
||||
((h (get q :head-idx)) (items (get q :items)))
|
||||
(if
|
||||
(>= h (len items))
|
||||
nil
|
||||
(let
|
||||
((x (nth items h)))
|
||||
(dict-set! q :head-idx (+ h 1))
|
||||
(er-q-compact! q)
|
||||
x)))))
|
||||
|
||||
(define
|
||||
er-q-peek
|
||||
(fn
|
||||
(q)
|
||||
(let
|
||||
((h (get q :head-idx)) (items (get q :items)))
|
||||
(if (>= h (len items)) nil (nth items h)))))
|
||||
|
||||
(define
|
||||
er-q-len
|
||||
(fn (q) (- (len (get q :items)) (get q :head-idx))))
|
||||
|
||||
(define er-q-empty? (fn (q) (= (er-q-len q) 0)))
|
||||
|
||||
;; Compact the backing list when the head pointer gets large so the
|
||||
;; queue doesn't grow without bound. Threshold chosen to amortise the
|
||||
;; O(n) copy — pops are still amortised O(1).
|
||||
(define
|
||||
er-q-compact!
|
||||
(fn
|
||||
(q)
|
||||
(let
|
||||
((h (get q :head-idx)) (items (get q :items)))
|
||||
(when
|
||||
(> h 128)
|
||||
(let
|
||||
((new (list)))
|
||||
(for-each
|
||||
(fn (i) (append! new (nth items i)))
|
||||
(range h (len items)))
|
||||
(dict-set! q :items new)
|
||||
(dict-set! q :head-idx 0))))))
|
||||
|
||||
(define
|
||||
er-q-to-list
|
||||
(fn
|
||||
(q)
|
||||
(let
|
||||
((h (get q :head-idx)) (items (get q :items)) (out (list)))
|
||||
(for-each
|
||||
(fn (i) (append! out (nth items i)))
|
||||
(range h (len items)))
|
||||
out)))
|
||||
|
||||
;; Read the i'th entry (relative to head) without popping.
|
||||
(define
|
||||
er-q-nth
|
||||
(fn (q i) (nth (get q :items) (+ (get q :head-idx) i))))
|
||||
|
||||
;; Remove entry at logical index i, shift tail in.
|
||||
(define
|
||||
er-q-delete-at!
|
||||
(fn
|
||||
(q i)
|
||||
(let
|
||||
((h (get q :head-idx)) (items (get q :items)) (new (list)))
|
||||
(for-each
|
||||
(fn
|
||||
(j)
|
||||
(when (not (= j (+ h i))) (append! new (nth items j))))
|
||||
(range h (len items)))
|
||||
(dict-set! q :items new)
|
||||
(dict-set! q :head-idx 0))))
|
||||
|
||||
;; ── pids ─────────────────────────────────────────────────────────
|
||||
(define er-mk-pid (fn (id) {:id id :tag "pid"}))
|
||||
(define er-pid? (fn (v) (er-is-tagged? v "pid")))
|
||||
(define er-pid-id (fn (pid) (get pid :id)))
|
||||
(define er-pid-key (fn (pid) (str "p" (er-pid-id pid))))
|
||||
(define
|
||||
er-pid-equal?
|
||||
(fn (a b) (and (er-pid? a) (er-pid? b) (= (er-pid-id a) (er-pid-id b)))))
|
||||
|
||||
;; ── refs ─────────────────────────────────────────────────────────
|
||||
(define er-mk-ref (fn (id) {:id id :tag "ref"}))
|
||||
(define er-ref? (fn (v) (er-is-tagged? v "ref")))
|
||||
(define
|
||||
er-ref-equal?
|
||||
(fn (a b) (and (er-ref? a) (er-ref? b) (= (get a :id) (get b :id)))))
|
||||
|
||||
(define
|
||||
er-ref-new!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((s (er-sched)))
|
||||
(let
|
||||
((n (get s :next-ref)))
|
||||
(dict-set! s :next-ref (+ n 1))
|
||||
(er-mk-ref n)))))
|
||||
|
||||
;; ── scheduler state ──────────────────────────────────────────────
|
||||
(define er-scheduler (list nil))
|
||||
|
||||
(define
|
||||
er-sched-init!
|
||||
(fn
|
||||
()
|
||||
(set-nth!
|
||||
er-scheduler
|
||||
0
|
||||
{:next-pid 0
|
||||
:next-ref 0
|
||||
:current nil
|
||||
:processes {}
|
||||
:runnable (er-q-new)})))
|
||||
|
||||
(define er-sched (fn () (nth er-scheduler 0)))
|
||||
|
||||
(define
|
||||
er-pid-new!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((s (er-sched)))
|
||||
(let
|
||||
((n (get s :next-pid)))
|
||||
(dict-set! s :next-pid (+ n 1))
|
||||
(er-mk-pid n)))))
|
||||
|
||||
(define
|
||||
er-sched-runnable
|
||||
(fn () (get (er-sched) :runnable)))
|
||||
|
||||
(define
|
||||
er-sched-processes
|
||||
(fn () (get (er-sched) :processes)))
|
||||
|
||||
(define
|
||||
er-sched-enqueue!
|
||||
(fn (pid) (er-q-push! (er-sched-runnable) pid)))
|
||||
|
||||
(define
|
||||
er-sched-next-runnable!
|
||||
(fn () (er-q-pop! (er-sched-runnable))))
|
||||
|
||||
(define
|
||||
er-sched-runnable-count
|
||||
(fn () (er-q-len (er-sched-runnable))))
|
||||
|
||||
(define
|
||||
er-sched-set-current!
|
||||
(fn (pid) (dict-set! (er-sched) :current pid)))
|
||||
|
||||
(define er-sched-current-pid (fn () (get (er-sched) :current)))
|
||||
|
||||
(define
|
||||
er-sched-process-count
|
||||
(fn () (len (keys (er-sched-processes)))))
|
||||
|
||||
;; ── process records ──────────────────────────────────────────────
|
||||
(define
|
||||
er-proc-new!
|
||||
(fn
|
||||
(env)
|
||||
(let
|
||||
((pid (er-pid-new!)))
|
||||
(let
|
||||
((proc
|
||||
{:pid pid
|
||||
:env env
|
||||
:links (list)
|
||||
:mailbox (er-q-new)
|
||||
:state "runnable"
|
||||
:monitors (list)
|
||||
:monitored-by (list)
|
||||
:continuation nil
|
||||
:receive-pats nil
|
||||
:trap-exit false
|
||||
:has-timeout false
|
||||
:timed-out false
|
||||
:exit-reason nil}))
|
||||
(dict-set! (er-sched-processes) (er-pid-key pid) proc)
|
||||
(er-sched-enqueue! pid)
|
||||
proc))))
|
||||
|
||||
(define
|
||||
er-proc-get
|
||||
(fn (pid) (get (er-sched-processes) (er-pid-key pid))))
|
||||
|
||||
(define
|
||||
er-proc-exists?
|
||||
(fn (pid) (dict-has? (er-sched-processes) (er-pid-key pid))))
|
||||
|
||||
(define
|
||||
er-proc-field
|
||||
(fn (pid field) (get (er-proc-get pid) field)))
|
||||
|
||||
(define
|
||||
er-proc-set!
|
||||
(fn
|
||||
(pid field val)
|
||||
(let
|
||||
((p (er-proc-get pid)))
|
||||
(if
|
||||
(= p nil)
|
||||
(error (str "Erlang: no such process " (er-pid-key pid)))
|
||||
(dict-set! p field val)))))
|
||||
|
||||
(define
|
||||
er-proc-mailbox-push!
|
||||
(fn (pid msg) (er-q-push! (er-proc-field pid :mailbox) msg)))
|
||||
|
||||
(define
|
||||
er-proc-mailbox-size
|
||||
(fn (pid) (er-q-len (er-proc-field pid :mailbox))))
|
||||
|
||||
;; Main process is always pid 0 (scheduler starts with next-pid 0 and
|
||||
;; erlang-eval-ast calls er-proc-new! first). Returns nil if no eval
|
||||
;; has run.
|
||||
(define
|
||||
er-main-pid
|
||||
(fn () (er-mk-pid 0)))
|
||||
|
||||
(define
|
||||
er-last-main-exit-reason
|
||||
(fn
|
||||
()
|
||||
(if
|
||||
(er-proc-exists? (er-main-pid))
|
||||
(er-proc-field (er-main-pid) :exit-reason)
|
||||
nil)))
|
||||
|
||||
;; ── process BIFs ────────────────────────────────────────────────
|
||||
(define
|
||||
er-bif-is-pid
|
||||
(fn (vs) (er-bool (er-pid? (er-bif-arg1 vs "is_pid")))))
|
||||
|
||||
(define
|
||||
er-bif-self
|
||||
(fn
|
||||
(vs)
|
||||
(if
|
||||
(not (= (len vs) 0))
|
||||
(error "Erlang: self/0: arity")
|
||||
(let
|
||||
((pid (er-sched-current-pid)))
|
||||
(if
|
||||
(= pid nil)
|
||||
(error "Erlang: self/0: no current process")
|
||||
pid)))))
|
||||
|
||||
(define
|
||||
er-bif-spawn
|
||||
(fn
|
||||
(vs)
|
||||
(cond
|
||||
(= (len vs) 1) (er-spawn-fun (nth vs 0))
|
||||
(= (len vs) 3) (error
|
||||
"Erlang: spawn/3: module-based spawn deferred to Phase 5 (modules)")
|
||||
:else (error "Erlang: spawn: wrong arity"))))
|
||||
|
||||
(define
|
||||
er-spawn-fun
|
||||
(fn
|
||||
(fv)
|
||||
(if
|
||||
(not (er-fun? fv))
|
||||
(error "Erlang: spawn/1: not a fun")
|
||||
(let
|
||||
((proc (er-proc-new! (er-env-new))))
|
||||
(dict-set! proc :initial-fun fv)
|
||||
(get proc :pid)))))
|
||||
|
||||
(define
|
||||
er-bif-exit
|
||||
(fn
|
||||
(vs)
|
||||
(cond
|
||||
(= (len vs) 1) (raise (er-mk-exit-marker (nth vs 0)))
|
||||
(= (len vs) 2)
|
||||
(error
|
||||
"Erlang: exit/2 (signal another process) deferred to next Phase 4 step (signal propagation)")
|
||||
:else (error "Erlang: exit: wrong arity"))))
|
||||
|
||||
;; ── links / monitors / refs ─────────────────────────────────────
|
||||
(define
|
||||
er-bif-is-reference
|
||||
(fn (vs) (er-bool (er-ref? (er-bif-arg1 vs "is_reference")))))
|
||||
|
||||
(define
|
||||
er-bif-make-ref
|
||||
(fn
|
||||
(vs)
|
||||
(if
|
||||
(not (= (len vs) 0))
|
||||
(error "Erlang: make_ref/0: arity")
|
||||
(er-ref-new!))))
|
||||
|
||||
;; Add `target` to `pid`'s :links list if not already there.
|
||||
(define
|
||||
er-link-add-one!
|
||||
(fn
|
||||
(pid target)
|
||||
(let
|
||||
((links (er-proc-field pid :links)))
|
||||
(when
|
||||
(not (er-link-has? links target))
|
||||
(append! links target)))))
|
||||
|
||||
(define
|
||||
er-link-has?
|
||||
(fn
|
||||
(links target)
|
||||
(cond
|
||||
(= (len links) 0) false
|
||||
(er-pid-equal? (nth links 0) target) true
|
||||
:else (er-link-has? (er-slice-list links 1) target))))
|
||||
|
||||
(define
|
||||
er-link-remove-one!
|
||||
(fn
|
||||
(pid target)
|
||||
(let
|
||||
((old (er-proc-field pid :links)) (out (list)))
|
||||
(for-each
|
||||
(fn
|
||||
(i)
|
||||
(let
|
||||
((p (nth old i)))
|
||||
(when (not (er-pid-equal? p target)) (append! out p))))
|
||||
(range 0 (len old)))
|
||||
(er-proc-set! pid :links out))))
|
||||
|
||||
(define
|
||||
er-bif-link
|
||||
(fn
|
||||
(vs)
|
||||
(let
|
||||
((target (er-bif-arg1 vs "link")) (me (er-sched-current-pid)))
|
||||
(cond
|
||||
(not (er-pid? target)) (error "Erlang: link: not a pid")
|
||||
(er-pid-equal? target me) (er-mk-atom "true")
|
||||
(not (er-proc-exists? target))
|
||||
(raise (er-mk-exit-marker (er-mk-atom "noproc")))
|
||||
:else (do
|
||||
(er-link-add-one! me target)
|
||||
(er-link-add-one! target me)
|
||||
(er-mk-atom "true"))))))
|
||||
|
||||
(define
|
||||
er-bif-unlink
|
||||
(fn
|
||||
(vs)
|
||||
(let
|
||||
((target (er-bif-arg1 vs "unlink")) (me (er-sched-current-pid)))
|
||||
(cond
|
||||
(not (er-pid? target)) (error "Erlang: unlink: not a pid")
|
||||
:else (do
|
||||
(er-link-remove-one! me target)
|
||||
(when
|
||||
(er-proc-exists? target)
|
||||
(er-link-remove-one! target me))
|
||||
(er-mk-atom "true"))))))
|
||||
|
||||
(define
|
||||
er-bif-monitor
|
||||
(fn
|
||||
(vs)
|
||||
(if
|
||||
(not (= (len vs) 2))
|
||||
(error "Erlang: monitor/2: arity")
|
||||
(let
|
||||
((kind (nth vs 0))
|
||||
(target (nth vs 1))
|
||||
(me (er-sched-current-pid)))
|
||||
(cond
|
||||
(not (and (er-atom? kind) (= (get kind :name) "process")))
|
||||
(error "Erlang: monitor: only 'process' supported")
|
||||
(not (er-pid? target)) (error "Erlang: monitor: not a pid")
|
||||
:else (let
|
||||
((ref (er-ref-new!)))
|
||||
(append!
|
||||
(er-proc-field me :monitors)
|
||||
{:ref ref :pid target})
|
||||
(when
|
||||
(er-proc-exists? target)
|
||||
(append!
|
||||
(er-proc-field target :monitored-by)
|
||||
{:from me :ref ref}))
|
||||
ref))))))
|
||||
|
||||
(define
|
||||
er-bif-demonitor
|
||||
(fn
|
||||
(vs)
|
||||
(let
|
||||
((ref (er-bif-arg1 vs "demonitor")) (me (er-sched-current-pid)))
|
||||
(if
|
||||
(not (er-ref? ref))
|
||||
(error "Erlang: demonitor: not a reference")
|
||||
(do
|
||||
(er-demonitor-purge! me ref)
|
||||
(er-mk-atom "true"))))))
|
||||
|
||||
(define
|
||||
er-demonitor-purge!
|
||||
(fn
|
||||
(me ref)
|
||||
(let
|
||||
((old (er-proc-field me :monitors)) (out (list)) (target-ref (list nil)))
|
||||
(for-each
|
||||
(fn
|
||||
(i)
|
||||
(let
|
||||
((m (nth old i)))
|
||||
(if
|
||||
(er-ref-equal? (get m :ref) ref)
|
||||
(set-nth! target-ref 0 (get m :pid))
|
||||
(append! out m))))
|
||||
(range 0 (len old)))
|
||||
(er-proc-set! me :monitors out)
|
||||
(when
|
||||
(and
|
||||
(not (= (nth target-ref 0) nil))
|
||||
(er-proc-exists? (nth target-ref 0)))
|
||||
(let
|
||||
((target (nth target-ref 0))
|
||||
(oldby (er-proc-field (nth target-ref 0) :monitored-by))
|
||||
(out2 (list)))
|
||||
(for-each
|
||||
(fn
|
||||
(i)
|
||||
(let
|
||||
((m (nth oldby i)))
|
||||
(when
|
||||
(not (er-ref-equal? (get m :ref) ref))
|
||||
(append! out2 m))))
|
||||
(range 0 (len oldby)))
|
||||
(er-proc-set! target :monitored-by out2))))))
|
||||
|
||||
;; ── scheduler loop ──────────────────────────────────────────────
|
||||
;; Each scheduler step wraps the process body in `guard`. `receive`
|
||||
;; with no match captures a `call/cc` continuation onto the proc
|
||||
;; record and then `raise`s `er-suspend-marker`; the guard catches
|
||||
;; the raise and the scheduler moves on. `exit/1` raises an exit
|
||||
;; marker the same way. Resumption from a saved continuation also
|
||||
;; runs under a fresh `guard` so a resumed receive that needs to
|
||||
;; suspend again has a handler to unwind to. `shift`/`reset` aren't
|
||||
;; usable here because SX's captured delimited continuations don't
|
||||
;; re-establish their own reset boundary when invoked — a second
|
||||
;; suspension during replay raises "shift without enclosing reset".
|
||||
(define er-suspend-marker {:tag "er-suspend-marker"})
|
||||
|
||||
(define
|
||||
er-suspended?
|
||||
(fn
|
||||
(v)
|
||||
(and
|
||||
(= (type-of v) "dict")
|
||||
(= (get v :tag) "er-suspend-marker"))))
|
||||
|
||||
(define
|
||||
er-exited?
|
||||
(fn
|
||||
(v)
|
||||
(and
|
||||
(= (type-of v) "dict")
|
||||
(= (get v :tag) "er-exit-marker"))))
|
||||
|
||||
(define
|
||||
er-mk-exit-marker
|
||||
(fn (reason) {:tag "er-exit-marker" :reason reason}))
|
||||
|
||||
(define
|
||||
er-sched-run-all!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((pid (er-sched-next-runnable!)))
|
||||
(cond
|
||||
(not (= pid nil))
|
||||
(do (er-sched-step! pid) (er-sched-run-all!))
|
||||
;; Queue empty — fire one pending receive-with-timeout and go again.
|
||||
(er-sched-fire-one-timeout!) (er-sched-run-all!)
|
||||
:else nil))))
|
||||
|
||||
;; Wake one waiting process whose receive had an `after Ms` clause.
|
||||
;; Returns true if one fired. In our synchronous model "time passes"
|
||||
;; once the runnable queue drains — timeouts only fire then.
|
||||
(define
|
||||
er-sched-fire-one-timeout!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((ks (keys (er-sched-processes))) (fired (list false)))
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(when
|
||||
(not (nth fired 0))
|
||||
(let
|
||||
((p (get (er-sched-processes) k)))
|
||||
(when
|
||||
(and
|
||||
(= (get p :state) "waiting")
|
||||
(get p :has-timeout))
|
||||
(dict-set! p :timed-out true)
|
||||
(dict-set! p :has-timeout false)
|
||||
(dict-set! p :state "runnable")
|
||||
(er-sched-enqueue! (get p :pid))
|
||||
(set-nth! fired 0 true)))))
|
||||
ks)
|
||||
(nth fired 0))))
|
||||
|
||||
(define
|
||||
er-sched-step!
|
||||
(fn
|
||||
(pid)
|
||||
(er-sched-set-current! pid)
|
||||
(er-proc-set! pid :state "running")
|
||||
(let
|
||||
((prev-k (er-proc-field pid :continuation))
|
||||
(result-ref (list nil)))
|
||||
(guard
|
||||
(c
|
||||
((er-suspended? c) (set-nth! result-ref 0 c))
|
||||
((er-exited? c) (set-nth! result-ref 0 c)))
|
||||
(set-nth!
|
||||
result-ref
|
||||
0
|
||||
(if
|
||||
(= prev-k nil)
|
||||
(er-apply-fun (er-proc-field pid :initial-fun) (list))
|
||||
(do (er-proc-set! pid :continuation nil) (prev-k nil)))))
|
||||
(let
|
||||
((r (nth result-ref 0)))
|
||||
(cond
|
||||
(er-suspended? r) nil
|
||||
(er-exited? r)
|
||||
(do
|
||||
(er-proc-set! pid :state "dead")
|
||||
(er-proc-set! pid :exit-reason (get r :reason))
|
||||
(er-proc-set! pid :exit-result nil)
|
||||
(er-proc-set! pid :continuation nil))
|
||||
:else (do
|
||||
(er-proc-set! pid :state "dead")
|
||||
(er-proc-set! pid :exit-reason (er-mk-atom "normal"))
|
||||
(er-proc-set! pid :exit-result r)
|
||||
(er-proc-set! pid :continuation nil)))))
|
||||
(er-sched-set-current! nil)))
|
||||
16
lib/erlang/scoreboard.json
Normal file
16
lib/erlang/scoreboard.json
Normal file
@@ -0,0 +1,16 @@
|
||||
{
|
||||
"language": "erlang",
|
||||
"total_pass": 375,
|
||||
"total": 375,
|
||||
"suites": [
|
||||
{"name":"tokenize","pass":62,"total":62,"status":"ok"},
|
||||
{"name":"parse","pass":52,"total":52,"status":"ok"},
|
||||
{"name":"eval","pass":191,"total":191,"status":"ok"},
|
||||
{"name":"runtime","pass":39,"total":39,"status":"ok"},
|
||||
{"name":"ring","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"ping-pong","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"bank","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"echo","pass":7,"total":7,"status":"ok"},
|
||||
{"name":"fib","pass":8,"total":8,"status":"ok"}
|
||||
]
|
||||
}
|
||||
18
lib/erlang/scoreboard.md
Normal file
18
lib/erlang/scoreboard.md
Normal file
@@ -0,0 +1,18 @@
|
||||
# Erlang-on-SX Scoreboard
|
||||
|
||||
**Total: 375 / 375 tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
| ✅ | tokenize | 62 | 62 |
|
||||
| ✅ | parse | 52 | 52 |
|
||||
| ✅ | eval | 191 | 191 |
|
||||
| ✅ | runtime | 39 | 39 |
|
||||
| ✅ | ring | 4 | 4 |
|
||||
| ✅ | ping-pong | 4 | 4 |
|
||||
| ✅ | bank | 8 | 8 |
|
||||
| ✅ | echo | 7 | 7 |
|
||||
| ✅ | fib | 8 | 8 |
|
||||
|
||||
|
||||
Generated by `lib/erlang/conformance.sh`.
|
||||
507
lib/erlang/tests/eval.sx
Normal file
507
lib/erlang/tests/eval.sx
Normal file
@@ -0,0 +1,507 @@
|
||||
;; Erlang evaluator tests — sequential expressions.
|
||||
|
||||
(define er-eval-test-count 0)
|
||||
(define er-eval-test-pass 0)
|
||||
(define er-eval-test-fails (list))
|
||||
|
||||
(define
|
||||
eev-deep=
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
(and (= (type-of a) "dict") (= (type-of b) "dict"))
|
||||
(let
|
||||
((ka (sort (keys a))) (kb (sort (keys b))))
|
||||
(and (= ka kb) (every? (fn (k) (eev-deep= (get a k) (get b k))) ka)))
|
||||
(and (= (type-of a) "list") (= (type-of b) "list"))
|
||||
(and
|
||||
(= (len a) (len b))
|
||||
(every? (fn (i) (eev-deep= (nth a i) (nth b i))) (range 0 (len a))))
|
||||
:else (= a b))))
|
||||
|
||||
(define
|
||||
er-eval-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! er-eval-test-count (+ er-eval-test-count 1))
|
||||
(if
|
||||
(eev-deep= actual expected)
|
||||
(set! er-eval-test-pass (+ er-eval-test-pass 1))
|
||||
(append! er-eval-test-fails {:actual actual :expected expected :name name}))))
|
||||
|
||||
(define ev erlang-eval-ast)
|
||||
(define nm (fn (v) (get v :name)))
|
||||
|
||||
;; ── literals ──────────────────────────────────────────────────────
|
||||
(er-eval-test "int" (ev "42") 42)
|
||||
(er-eval-test "zero" (ev "0") 0)
|
||||
(er-eval-test "float" (ev "3.14") 3.14)
|
||||
(er-eval-test "string" (ev "\"hi\"") "hi")
|
||||
(er-eval-test "atom" (nm (ev "ok")) "ok")
|
||||
(er-eval-test "atom true" (nm (ev "true")) "true")
|
||||
(er-eval-test "atom false" (nm (ev "false")) "false")
|
||||
|
||||
;; ── arithmetic ────────────────────────────────────────────────────
|
||||
(er-eval-test "add" (ev "1 + 2") 3)
|
||||
(er-eval-test "sub" (ev "5 - 3") 2)
|
||||
(er-eval-test "mul" (ev "4 * 3") 12)
|
||||
(er-eval-test "div-real" (ev "10 / 4") 2.5)
|
||||
(er-eval-test "div-int" (ev "10 div 3") 3)
|
||||
(er-eval-test "rem" (ev "10 rem 3") 1)
|
||||
(er-eval-test "div-neg" (ev "-10 div 3") -3)
|
||||
(er-eval-test "precedence" (ev "1 + 2 * 3") 7)
|
||||
(er-eval-test "parens" (ev "(1 + 2) * 3") 9)
|
||||
(er-eval-test "unary-neg" (ev "-(1 + 2)") -3)
|
||||
(er-eval-test "unary-neg int" (ev "-7") -7)
|
||||
|
||||
;; ── comparison ────────────────────────────────────────────────────
|
||||
(er-eval-test "lt true" (nm (ev "1 < 2")) "true")
|
||||
(er-eval-test "gt false" (nm (ev "1 > 2")) "false")
|
||||
(er-eval-test "le equal" (nm (ev "2 =< 2")) "true")
|
||||
(er-eval-test "ge equal" (nm (ev "2 >= 2")) "true")
|
||||
(er-eval-test "eq" (nm (ev "2 == 2")) "true")
|
||||
(er-eval-test "neq" (nm (ev "1 /= 2")) "true")
|
||||
(er-eval-test "exact-eq same" (nm (ev "1 =:= 1")) "true")
|
||||
(er-eval-test "exact-neq int" (nm (ev "1 =:= 2")) "false")
|
||||
(er-eval-test "=/= true" (nm (ev "1 =/= 2")) "true")
|
||||
(er-eval-test "atom-eq" (nm (ev "ok == ok")) "true")
|
||||
(er-eval-test "atom-neq" (nm (ev "ok == error")) "false")
|
||||
|
||||
;; ── logical ───────────────────────────────────────────────────────
|
||||
(er-eval-test "and tt" (nm (ev "true and true")) "true")
|
||||
(er-eval-test "and tf" (nm (ev "true and false")) "false")
|
||||
(er-eval-test "or tf" (nm (ev "true or false")) "true")
|
||||
(er-eval-test
|
||||
"andalso short"
|
||||
(nm (ev "false andalso Neverref"))
|
||||
"false")
|
||||
(er-eval-test
|
||||
"orelse short"
|
||||
(nm (ev "true orelse Neverref"))
|
||||
"true")
|
||||
(er-eval-test "not true" (nm (ev "not true")) "false")
|
||||
(er-eval-test "not false" (nm (ev "not false")) "true")
|
||||
|
||||
;; ── tuples & lists ────────────────────────────────────────────────
|
||||
(er-eval-test "tuple tag" (get (ev "{1, 2, 3}") :tag) "tuple")
|
||||
(er-eval-test "tuple len" (len (get (ev "{1, 2, 3}") :elements)) 3)
|
||||
(er-eval-test "tuple elem" (nth (get (ev "{10, 20}") :elements) 1) 20)
|
||||
(er-eval-test "empty tuple" (len (get (ev "{}") :elements)) 0)
|
||||
(er-eval-test "nested tuple"
|
||||
(nm (nth (get (ev "{ok, error}") :elements) 0)) "ok")
|
||||
(er-eval-test "nil list" (get (ev "[]") :tag) "nil")
|
||||
(er-eval-test "list head" (get (ev "[1, 2, 3]") :head) 1)
|
||||
(er-eval-test
|
||||
"list tail tail head"
|
||||
(get (get (get (ev "[1, 2, 3]") :tail) :tail) :head)
|
||||
3)
|
||||
|
||||
;; ── list ops ──────────────────────────────────────────────────────
|
||||
(er-eval-test "++ head" (get (ev "[1, 2] ++ [3]") :head) 1)
|
||||
(er-eval-test "++ last"
|
||||
(get (get (get (ev "[1, 2] ++ [3]") :tail) :tail) :head) 3)
|
||||
|
||||
;; ── block ─────────────────────────────────────────────────────────
|
||||
(er-eval-test "block last wins" (ev "begin 1, 2, 3 end") 3)
|
||||
(er-eval-test "bare body" (ev "1, 2, 99") 99)
|
||||
|
||||
;; ── match + var ───────────────────────────────────────────────────
|
||||
(er-eval-test "match bind-and-use" (ev "X = 5, X + 1") 6)
|
||||
(er-eval-test "match sequential" (ev "X = 1, Y = 2, X + Y") 3)
|
||||
(er-eval-test
|
||||
"rebind equal ok"
|
||||
(ev "X = 5, X = 5, X") 5)
|
||||
|
||||
;; ── if ────────────────────────────────────────────────────────────
|
||||
(er-eval-test "if picks first" (ev "if true -> 1; true -> 2 end") 1)
|
||||
(er-eval-test
|
||||
"if picks second"
|
||||
(nm (ev "if 1 > 2 -> bad; true -> good end"))
|
||||
"good")
|
||||
(er-eval-test
|
||||
"if with guard"
|
||||
(ev "X = 5, if X > 0 -> 1; true -> 0 end")
|
||||
1)
|
||||
|
||||
;; ── pattern matching ─────────────────────────────────────────────
|
||||
(er-eval-test "match atom literal" (nm (ev "ok = ok, done")) "done")
|
||||
(er-eval-test "match int literal" (ev "5 = 5, 42") 42)
|
||||
(er-eval-test "match tuple bind"
|
||||
(ev "{ok, V} = {ok, 99}, V") 99)
|
||||
(er-eval-test "match tuple nested"
|
||||
(ev "{A, {B, C}} = {1, {2, 3}}, A + B + C") 6)
|
||||
(er-eval-test "match cons head"
|
||||
(ev "[H|T] = [1, 2, 3], H") 1)
|
||||
(er-eval-test "match cons tail head"
|
||||
(ev "[_, H|_] = [1, 2, 3], H") 2)
|
||||
(er-eval-test "match nil"
|
||||
(ev "[] = [], 7") 7)
|
||||
(er-eval-test "match wildcard always"
|
||||
(ev "_ = 42, 7") 7)
|
||||
(er-eval-test "match var reuse equal"
|
||||
(ev "X = 5, X = 5, X") 5)
|
||||
|
||||
;; ── case ─────────────────────────────────────────────────────────
|
||||
(er-eval-test "case bind" (ev "case 5 of N -> N end") 5)
|
||||
(er-eval-test "case tuple"
|
||||
(ev "case {ok, 42} of {ok, V} -> V end") 42)
|
||||
(er-eval-test "case cons"
|
||||
(ev "case [1, 2, 3] of [H|_] -> H end") 1)
|
||||
(er-eval-test "case fallthrough"
|
||||
(ev "case error of ok -> 1; error -> 2 end") 2)
|
||||
(er-eval-test "case wildcard"
|
||||
(nm (ev "case x of ok -> ok; _ -> err end"))
|
||||
"err")
|
||||
(er-eval-test "case guard"
|
||||
(ev "case 5 of N when N > 0 -> pos; _ -> neg end")
|
||||
(er-mk-atom "pos"))
|
||||
(er-eval-test "case guard fallthrough"
|
||||
(ev "case -3 of N when N > 0 -> pos; _ -> neg end")
|
||||
(er-mk-atom "neg"))
|
||||
(er-eval-test "case bound re-match"
|
||||
(ev "X = 5, case 5 of X -> same; _ -> diff end")
|
||||
(er-mk-atom "same"))
|
||||
(er-eval-test "case bound re-match fail"
|
||||
(ev "X = 5, case 6 of X -> same; _ -> diff end")
|
||||
(er-mk-atom "diff"))
|
||||
(er-eval-test "case nested tuple"
|
||||
(ev "case {ok, {value, 42}} of {ok, {value, V}} -> V end")
|
||||
42)
|
||||
(er-eval-test "case multi-clause"
|
||||
(ev "case 2 of 1 -> one; 2 -> two; _ -> other end")
|
||||
(er-mk-atom "two"))
|
||||
(er-eval-test "case leak binding"
|
||||
(ev "case {ok, 7} of {ok, X} -> X end + 1")
|
||||
8)
|
||||
|
||||
;; ── guard BIFs (is_*) ────────────────────────────────────────────
|
||||
(er-eval-test "is_integer 42" (nm (ev "is_integer(42)")) "true")
|
||||
(er-eval-test "is_integer ok" (nm (ev "is_integer(ok)")) "false")
|
||||
(er-eval-test "is_atom ok" (nm (ev "is_atom(ok)")) "true")
|
||||
(er-eval-test "is_atom int" (nm (ev "is_atom(42)")) "false")
|
||||
(er-eval-test "is_list cons" (nm (ev "is_list([1,2])")) "true")
|
||||
(er-eval-test "is_list nil" (nm (ev "is_list([])")) "true")
|
||||
(er-eval-test "is_list tuple" (nm (ev "is_list({1,2})")) "false")
|
||||
(er-eval-test "is_tuple tuple" (nm (ev "is_tuple({ok,1})")) "true")
|
||||
(er-eval-test "is_tuple list" (nm (ev "is_tuple([1])")) "false")
|
||||
(er-eval-test "is_number int" (nm (ev "is_number(42)")) "true")
|
||||
(er-eval-test "is_number atom" (nm (ev "is_number(foo)")) "false")
|
||||
(er-eval-test "is_boolean true" (nm (ev "is_boolean(true)")) "true")
|
||||
(er-eval-test "is_boolean false" (nm (ev "is_boolean(false)")) "true")
|
||||
(er-eval-test "is_boolean atom" (nm (ev "is_boolean(foo)")) "false")
|
||||
|
||||
;; ── guard BIFs wired into case / if ─────────────────────────────
|
||||
(er-eval-test "guard is_integer pick"
|
||||
(nm (ev "case 5 of N when is_integer(N) -> int; _ -> other end"))
|
||||
"int")
|
||||
(er-eval-test "guard is_integer reject"
|
||||
(nm (ev "case foo of N when is_integer(N) -> int; _ -> other end"))
|
||||
"other")
|
||||
(er-eval-test "guard is_atom"
|
||||
(nm (ev "case foo of X when is_atom(X) -> atom_yes; _ -> no end"))
|
||||
"atom_yes")
|
||||
(er-eval-test "guard conjunction"
|
||||
(nm (ev "case 5 of N when is_integer(N), N > 0 -> pos; _ -> np end"))
|
||||
"pos")
|
||||
(er-eval-test "guard disjunction (if)"
|
||||
(nm (ev "X = foo, if is_integer(X); is_atom(X) -> yes; true -> no end"))
|
||||
"yes")
|
||||
(er-eval-test "guard arith"
|
||||
(nm (ev "case 3 of N when N * 2 > 5 -> big; _ -> small end"))
|
||||
"big")
|
||||
|
||||
;; ── BIFs: list + tuple ──────────────────────────────────────────
|
||||
(er-eval-test "length empty" (ev "length([])") 0)
|
||||
(er-eval-test "length 3" (ev "length([a, b, c])") 3)
|
||||
(er-eval-test "length cons chain" (ev "length([1 | [2 | [3 | []]]])") 3)
|
||||
(er-eval-test "hd" (ev "hd([10, 20, 30])") 10)
|
||||
(er-eval-test "hd atom"
|
||||
(nm (ev "hd([ok, err])")) "ok")
|
||||
(er-eval-test "tl head"
|
||||
(get (ev "tl([1, 2, 3])") :head) 2)
|
||||
(er-eval-test "tl of single" (get (ev "tl([1])") :tag) "nil")
|
||||
(er-eval-test "element 1" (nm (ev "element(1, {ok, value})")) "ok")
|
||||
(er-eval-test "element 2" (ev "element(2, {ok, 42})") 42)
|
||||
(er-eval-test "element 3"
|
||||
(nm (ev "element(3, {a, b, c, d})")) "c")
|
||||
(er-eval-test "tuple_size 2" (ev "tuple_size({a, b})") 2)
|
||||
(er-eval-test "tuple_size 0" (ev "tuple_size({})") 0)
|
||||
|
||||
;; ── BIFs: atom / list conversions ───────────────────────────────
|
||||
(er-eval-test "atom_to_list" (ev "atom_to_list(hello)") "hello")
|
||||
(er-eval-test "list_to_atom roundtrip"
|
||||
(nm (ev "list_to_atom(atom_to_list(foo))")) "foo")
|
||||
(er-eval-test "list_to_atom fresh"
|
||||
(nm (ev "list_to_atom(\"bar\")")) "bar")
|
||||
|
||||
;; ── lists module ────────────────────────────────────────────────
|
||||
(er-eval-test "lists:reverse empty"
|
||||
(get (ev "lists:reverse([])") :tag) "nil")
|
||||
(er-eval-test "lists:reverse 3"
|
||||
(ev "hd(lists:reverse([1, 2, 3]))") 3)
|
||||
(er-eval-test "lists:reverse full"
|
||||
(ev "lists:foldl(fun (X, Acc) -> Acc + X end, 0, lists:reverse([1, 2, 3]))") 6)
|
||||
|
||||
;; ── funs + lists:map / lists:foldl ──────────────────────────────
|
||||
(er-eval-test "fun call" (ev "F = fun (X) -> X + 1 end, F(10)") 11)
|
||||
(er-eval-test "fun two-arg"
|
||||
(ev "F = fun (X, Y) -> X * Y end, F(3, 4)") 12)
|
||||
(er-eval-test "fun closure"
|
||||
(ev "N = 100, F = fun (X) -> X + N end, F(5)") 105)
|
||||
(er-eval-test "fun clauses"
|
||||
(ev "F = fun (0) -> zero; (N) -> N end, element(1, {F(0), F(7)})")
|
||||
(er-mk-atom "zero"))
|
||||
(er-eval-test "fun multi-clause second"
|
||||
(ev "F = fun (0) -> 0; (N) -> N * 2 end, F(5)") 10)
|
||||
(er-eval-test "lists:map empty"
|
||||
(get (ev "lists:map(fun (X) -> X end, [])") :tag) "nil")
|
||||
(er-eval-test "lists:map double"
|
||||
(ev "hd(lists:map(fun (X) -> X * 2 end, [1, 2, 3]))") 2)
|
||||
(er-eval-test "lists:map sum-length"
|
||||
(ev "length(lists:map(fun (X) -> X end, [a, b, c, d]))") 4)
|
||||
(er-eval-test "lists:foldl sum"
|
||||
(ev "lists:foldl(fun (X, Acc) -> X + Acc end, 0, [1, 2, 3, 4, 5])") 15)
|
||||
(er-eval-test "lists:foldl product"
|
||||
(ev "lists:foldl(fun (X, Acc) -> X * Acc end, 1, [1, 2, 3, 4])") 24)
|
||||
(er-eval-test "lists:foldl as reverse"
|
||||
(ev "hd(lists:foldl(fun (X, Acc) -> [X | Acc] end, [], [1, 2, 3]))") 3)
|
||||
|
||||
;; ── io:format (via capture buffer) ──────────────────────────────
|
||||
(er-eval-test "io:format plain"
|
||||
(do (er-io-flush!) (ev "io:format(\"hello~n\")") (er-io-buffer-content))
|
||||
"hello\n")
|
||||
(er-eval-test "io:format args"
|
||||
(do (er-io-flush!) (ev "io:format(\"x=~p y=~p~n\", [42, hello])") (er-io-buffer-content))
|
||||
"x=42 y=hello\n")
|
||||
(er-eval-test "io:format returns ok"
|
||||
(nm (do (er-io-flush!) (ev "io:format(\"~n\")"))) "ok")
|
||||
(er-eval-test "io:format tuple"
|
||||
(do (er-io-flush!) (ev "io:format(\"~p\", [{ok, 1}])") (er-io-buffer-content))
|
||||
"{ok,1}")
|
||||
(er-eval-test "io:format list"
|
||||
(do (er-io-flush!) (ev "io:format(\"~p\", [[1,2,3]])") (er-io-buffer-content))
|
||||
"[1,2,3]")
|
||||
(er-eval-test "io:format escape"
|
||||
(do (er-io-flush!) (ev "io:format(\"50~~\")") (er-io-buffer-content))
|
||||
"50~")
|
||||
|
||||
;; ── processes: self/0, spawn/1, is_pid ──────────────────────────
|
||||
(er-eval-test "self tag"
|
||||
(get (ev "self()") :tag) "pid")
|
||||
(er-eval-test "is_pid self"
|
||||
(nm (ev "is_pid(self())")) "true")
|
||||
(er-eval-test "is_pid number"
|
||||
(nm (ev "is_pid(42)")) "false")
|
||||
(er-eval-test "is_pid atom"
|
||||
(nm (ev "is_pid(ok)")) "false")
|
||||
(er-eval-test "self equals self"
|
||||
(nm (ev "Pid = self(), Pid =:= Pid")) "true")
|
||||
(er-eval-test "self =:= self expr"
|
||||
(nm (ev "self() == self()")) "true")
|
||||
(er-eval-test "spawn returns pid"
|
||||
(get (ev "spawn(fun () -> ok end)") :tag) "pid")
|
||||
(er-eval-test "is_pid spawn"
|
||||
(nm (ev "is_pid(spawn(fun () -> ok end))")) "true")
|
||||
(er-eval-test "spawn new pid distinct"
|
||||
(nm (ev "P1 = self(), P2 = spawn(fun () -> ok end), P1 =:= P2"))
|
||||
"false")
|
||||
(er-eval-test "two spawns distinct"
|
||||
(nm (ev "P1 = spawn(fun () -> ok end), P2 = spawn(fun () -> ok end), P1 =:= P2"))
|
||||
"false")
|
||||
(er-eval-test "spawn then drain io"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(ev "spawn(fun () -> io:format(\"child~n\") end), io:format(\"parent~n\")")
|
||||
(er-io-buffer-content))
|
||||
"parent\nchild\n")
|
||||
(er-eval-test "multiple spawn ordering"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(ev "spawn(fun () -> io:format(\"a~n\") end), spawn(fun () -> io:format(\"b~n\") end), io:format(\"main~n\")")
|
||||
(er-io-buffer-content))
|
||||
"main\na\nb\n")
|
||||
(er-eval-test "child self is its own pid"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(ev "P = spawn(fun () -> io:format(\"~p\", [is_pid(self())]) end), io:format(\"~p;\", [is_pid(P)])")
|
||||
(er-io-buffer-content))
|
||||
"true;true")
|
||||
|
||||
;; ── ! (send) + receive ──────────────────────────────────────────
|
||||
(er-eval-test "self-send + receive"
|
||||
(nm (ev "Me = self(), Me ! hello, receive Msg -> Msg end")) "hello")
|
||||
(er-eval-test "send returns msg"
|
||||
(nm (ev "Me = self(), Msg = Me ! ok, Me ! x, receive _ -> Msg end")) "ok")
|
||||
(er-eval-test "receive int"
|
||||
(ev "Me = self(), Me ! 42, receive N -> N + 1 end") 43)
|
||||
(er-eval-test "receive with pattern"
|
||||
(ev "Me = self(), Me ! {ok, 7}, receive {ok, V} -> V * 2 end") 14)
|
||||
(er-eval-test "receive with guard"
|
||||
(ev "Me = self(), Me ! 5, receive N when N > 0 -> positive end")
|
||||
(er-mk-atom "positive"))
|
||||
(er-eval-test "receive skips non-match"
|
||||
(nm (ev "Me = self(), Me ! wrong, Me ! right, receive right -> ok end"))
|
||||
"ok")
|
||||
(er-eval-test "receive selective leaves others"
|
||||
(nm (ev "Me = self(), Me ! a, Me ! b, receive b -> got_b end"))
|
||||
"got_b")
|
||||
(er-eval-test "two receives consume both"
|
||||
(ev "Me = self(), Me ! 1, Me ! 2, X = receive A -> A end, Y = receive B -> B end, X + Y") 3)
|
||||
|
||||
;; ── spawn + send + receive (real process communication) ─────────
|
||||
(er-eval-test "spawn sends back"
|
||||
(nm
|
||||
(ev "Me = self(), spawn(fun () -> Me ! pong end), receive pong -> got_pong end"))
|
||||
"got_pong")
|
||||
(er-eval-test "ping-pong"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(ev "Me = self(), Child = spawn(fun () -> receive {ping, From} -> From ! pong end end), Child ! {ping, Me}, receive pong -> io:format(\"pong~n\") end")
|
||||
(er-io-buffer-content))
|
||||
"pong\n")
|
||||
(er-eval-test "echo server"
|
||||
(ev "Me = self(), Echo = spawn(fun () -> receive {From, Msg} -> From ! Msg end end), Echo ! {Me, 99}, receive R -> R end") 99)
|
||||
|
||||
;; ── receive with multiple clauses ────────────────────────────────
|
||||
(er-eval-test "receive multi-clause"
|
||||
(nm (ev "Me = self(), Me ! foo, receive ok -> a; foo -> b; bar -> c end"))
|
||||
"b")
|
||||
(er-eval-test "receive nested tuple"
|
||||
(ev "Me = self(), Me ! {result, {ok, 42}}, receive {result, {ok, V}} -> V end") 42)
|
||||
|
||||
;; ── receive ... after ... ───────────────────────────────────────
|
||||
(er-eval-test "after 0 empty mailbox"
|
||||
(nm (ev "receive _ -> got after 0 -> timeout end"))
|
||||
"timeout")
|
||||
(er-eval-test "after 0 match wins"
|
||||
(nm (ev "Me = self(), Me ! ok, receive ok -> got after 0 -> timeout end"))
|
||||
"got")
|
||||
(er-eval-test "after 0 non-match fires timeout"
|
||||
(nm (ev "Me = self(), Me ! wrong, receive right -> got after 0 -> timeout end"))
|
||||
"timeout")
|
||||
(er-eval-test "after 0 leaves non-match"
|
||||
(ev "Me = self(), Me ! wrong, receive right -> got after 0 -> to end, receive X -> X end")
|
||||
(er-mk-atom "wrong"))
|
||||
(er-eval-test "after Ms no sender — timeout fires"
|
||||
(nm (ev "receive _ -> got after 100 -> timed_out end"))
|
||||
"timed_out")
|
||||
(er-eval-test "after Ms with sender — match wins"
|
||||
(nm (ev "Me = self(), spawn(fun () -> Me ! hi end), receive hi -> got after 100 -> to end"))
|
||||
"got")
|
||||
(er-eval-test "after Ms computed"
|
||||
(nm (ev "Ms = 50, receive _ -> got after Ms -> done end"))
|
||||
"done")
|
||||
(er-eval-test "after 0 body side effect"
|
||||
(do (er-io-flush!)
|
||||
(ev "receive _ -> ok after 0 -> io:format(\"to~n\") end")
|
||||
(er-io-buffer-content))
|
||||
"to\n")
|
||||
(er-eval-test "after zero poll selective"
|
||||
(ev "Me = self(), Me ! first, Me ! second, X = receive second -> got_second after 0 -> to end, Y = receive first -> got_first after 0 -> to end, {X, Y}")
|
||||
(er-mk-tuple (list (er-mk-atom "got_second") (er-mk-atom "got_first"))))
|
||||
|
||||
;; ── exit/1 + process termination ─────────────────────────────────
|
||||
(er-eval-test "exit normal returns nil" (ev "exit(normal)") nil)
|
||||
(er-eval-test "exit normal reason"
|
||||
(do (ev "exit(normal)") (nm (er-last-main-exit-reason))) "normal")
|
||||
(er-eval-test "exit bye reason"
|
||||
(do (ev "exit(bye)") (nm (er-last-main-exit-reason))) "bye")
|
||||
(er-eval-test "exit tuple reason"
|
||||
(do (ev "exit({shutdown, crash})")
|
||||
(get (er-last-main-exit-reason) :tag))
|
||||
"tuple")
|
||||
(er-eval-test "normal completion reason"
|
||||
(do (ev "42") (nm (er-last-main-exit-reason))) "normal")
|
||||
(er-eval-test "exit aborts subsequent"
|
||||
(do (er-io-flush!) (ev "io:format(\"a~n\"), exit(bye), io:format(\"b~n\")") (er-io-buffer-content))
|
||||
"a\n")
|
||||
(er-eval-test "child exit doesn't kill parent"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(ev "spawn(fun () -> io:format(\"before~n\"), exit(quit), io:format(\"after~n\") end), io:format(\"main~n\")")
|
||||
(er-io-buffer-content))
|
||||
"main\nbefore\n")
|
||||
(er-eval-test "child exit reason recorded on child"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(ev "P = spawn(fun () -> exit(child_bye) end), io:format(\"~p\", [is_pid(P)])")
|
||||
(er-io-buffer-content))
|
||||
"true")
|
||||
(er-eval-test "exit inside fn chain"
|
||||
(do (ev "F = fun () -> exit(from_fn) end, F()")
|
||||
(nm (er-last-main-exit-reason)))
|
||||
"from_fn")
|
||||
|
||||
;; ── refs / link / monitor ──────────────────────────────────────
|
||||
(er-eval-test "make_ref tag"
|
||||
(get (ev "make_ref()") :tag) "ref")
|
||||
(er-eval-test "is_reference fresh"
|
||||
(nm (ev "R = make_ref(), is_reference(R)")) "true")
|
||||
(er-eval-test "is_reference pid"
|
||||
(nm (ev "is_reference(self())")) "false")
|
||||
(er-eval-test "is_reference number"
|
||||
(nm (ev "is_reference(42)")) "false")
|
||||
(er-eval-test "make_ref distinct"
|
||||
(nm (ev "R1 = make_ref(), R2 = make_ref(), R1 =:= R2")) "false")
|
||||
(er-eval-test "make_ref same id eq"
|
||||
(nm (ev "R = make_ref(), R =:= R")) "true")
|
||||
|
||||
(er-eval-test "link returns true"
|
||||
(nm (ev "P = spawn(fun () -> ok end), link(P)")) "true")
|
||||
(er-eval-test "self link returns true"
|
||||
(nm (ev "link(self())")) "true")
|
||||
(er-eval-test "unlink returns true"
|
||||
(nm (ev "P = spawn(fun () -> ok end), link(P), unlink(P)")) "true")
|
||||
(er-eval-test "unlink without link"
|
||||
(nm (ev "P = spawn(fun () -> ok end), unlink(P)")) "true")
|
||||
|
||||
(er-eval-test "monitor returns ref"
|
||||
(get (ev "P = spawn(fun () -> ok end), monitor(process, P)") :tag)
|
||||
"ref")
|
||||
(er-eval-test "monitor refs distinct"
|
||||
(nm (ev "P = spawn(fun () -> ok end), R1 = monitor(process, P), R2 = monitor(process, P), R1 =:= R2"))
|
||||
"false")
|
||||
(er-eval-test "demonitor returns true"
|
||||
(nm (ev "P = spawn(fun () -> ok end), R = monitor(process, P), demonitor(R)"))
|
||||
"true")
|
||||
|
||||
;; Bidirectional link recorded on both sides.
|
||||
(er-eval-test "link bidirectional"
|
||||
(do
|
||||
(ev "P = spawn(fun () -> receive forever -> ok end end), link(P)")
|
||||
;; After eval, check links on main + child via accessors.
|
||||
(and
|
||||
(= (len (er-proc-field (er-mk-pid 0) :links)) 1)
|
||||
(= (len (er-proc-field (er-mk-pid 1) :links)) 1)))
|
||||
true)
|
||||
|
||||
;; unlink clears both sides.
|
||||
(er-eval-test "unlink clears both"
|
||||
(do
|
||||
(ev "P = spawn(fun () -> receive forever -> ok end end), link(P), unlink(P)")
|
||||
(and
|
||||
(= (len (er-proc-field (er-mk-pid 0) :links)) 0)
|
||||
(= (len (er-proc-field (er-mk-pid 1) :links)) 0)))
|
||||
true)
|
||||
|
||||
;; monitor adds entries to both lists.
|
||||
(er-eval-test "monitor records both sides"
|
||||
(do
|
||||
(ev "P = spawn(fun () -> receive forever -> ok end end), monitor(process, P)")
|
||||
(and
|
||||
(= (len (er-proc-field (er-mk-pid 0) :monitors)) 1)
|
||||
(= (len (er-proc-field (er-mk-pid 1) :monitored-by)) 1)))
|
||||
true)
|
||||
|
||||
;; demonitor clears both lists.
|
||||
(er-eval-test "demonitor clears both"
|
||||
(do
|
||||
(ev "P = spawn(fun () -> receive forever -> ok end end), R = monitor(process, P), demonitor(R)")
|
||||
(and
|
||||
(= (len (er-proc-field (er-mk-pid 0) :monitors)) 0)
|
||||
(= (len (er-proc-field (er-mk-pid 1) :monitored-by)) 0)))
|
||||
true)
|
||||
|
||||
(define
|
||||
er-eval-test-summary
|
||||
(str "eval " er-eval-test-pass "/" er-eval-test-count))
|
||||
159
lib/erlang/tests/programs/bank.sx
Normal file
159
lib/erlang/tests/programs/bank.sx
Normal file
@@ -0,0 +1,159 @@
|
||||
;; Bank account server — stateful process, balance threaded through
|
||||
;; recursive loop. Handles {deposit, Amt, From}, {withdraw, Amt, From},
|
||||
;; {balance, From}, stop. Tests stateful process patterns.
|
||||
|
||||
(define er-bank-test-count 0)
|
||||
(define er-bank-test-pass 0)
|
||||
(define er-bank-test-fails (list))
|
||||
|
||||
(define
|
||||
er-bank-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! er-bank-test-count (+ er-bank-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! er-bank-test-pass (+ er-bank-test-pass 1))
|
||||
(append! er-bank-test-fails {:actual actual :expected expected :name name}))))
|
||||
|
||||
(define bank-ev erlang-eval-ast)
|
||||
|
||||
;; Server fun shared by all tests — threaded via the program string.
|
||||
(define
|
||||
er-bank-server-src
|
||||
"Server = fun (Balance) ->
|
||||
receive
|
||||
{deposit, Amt, From} -> From ! ok, Server(Balance + Amt);
|
||||
{withdraw, Amt, From} ->
|
||||
if Amt > Balance -> From ! insufficient, Server(Balance);
|
||||
true -> From ! ok, Server(Balance - Amt)
|
||||
end;
|
||||
{balance, From} -> From ! Balance, Server(Balance);
|
||||
stop -> ok
|
||||
end
|
||||
end")
|
||||
|
||||
;; Open account, deposit, check balance.
|
||||
(er-bank-test
|
||||
"deposit 100 -> balance 100"
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(0) end),
|
||||
Bank ! {deposit, 100, Me},
|
||||
receive ok -> ok end,
|
||||
Bank ! {balance, Me},
|
||||
receive B -> Bank ! stop, B end"))
|
||||
100)
|
||||
|
||||
;; Multiple deposits accumulate.
|
||||
(er-bank-test
|
||||
"deposits accumulate"
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(0) end),
|
||||
Bank ! {deposit, 50, Me}, receive ok -> ok end,
|
||||
Bank ! {deposit, 25, Me}, receive ok -> ok end,
|
||||
Bank ! {deposit, 10, Me}, receive ok -> ok end,
|
||||
Bank ! {balance, Me},
|
||||
receive B -> Bank ! stop, B end"))
|
||||
85)
|
||||
|
||||
;; Withdraw within balance succeeds; insufficient gets rejected.
|
||||
(er-bank-test
|
||||
"withdraw within balance"
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(100) end),
|
||||
Bank ! {withdraw, 30, Me}, receive ok -> ok end,
|
||||
Bank ! {balance, Me},
|
||||
receive B -> Bank ! stop, B end"))
|
||||
70)
|
||||
|
||||
(er-bank-test
|
||||
"withdraw insufficient"
|
||||
(get
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(20) end),
|
||||
Bank ! {withdraw, 100, Me},
|
||||
receive R -> Bank ! stop, R end"))
|
||||
:name)
|
||||
"insufficient")
|
||||
|
||||
;; State preserved across an insufficient withdrawal.
|
||||
(er-bank-test
|
||||
"state preserved on rejection"
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(50) end),
|
||||
Bank ! {withdraw, 1000, Me}, receive _ -> ok end,
|
||||
Bank ! {balance, Me},
|
||||
receive B -> Bank ! stop, B end"))
|
||||
50)
|
||||
|
||||
;; Mixed deposits and withdrawals.
|
||||
(er-bank-test
|
||||
"mixed transactions"
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(100) end),
|
||||
Bank ! {deposit, 50, Me}, receive ok -> ok end,
|
||||
Bank ! {withdraw, 30, Me}, receive ok -> ok end,
|
||||
Bank ! {deposit, 10, Me}, receive ok -> ok end,
|
||||
Bank ! {withdraw, 5, Me}, receive ok -> ok end,
|
||||
Bank ! {balance, Me},
|
||||
receive B -> Bank ! stop, B end"))
|
||||
125)
|
||||
|
||||
;; Server.stop terminates the bank cleanly — main can verify by
|
||||
;; sending stop and then exiting normally.
|
||||
(er-bank-test
|
||||
"server stops cleanly"
|
||||
(get
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(0) end),
|
||||
Bank ! stop,
|
||||
done"))
|
||||
:name)
|
||||
"done")
|
||||
|
||||
;; Two clients sharing one bank — interleaved transactions.
|
||||
(er-bank-test
|
||||
"two clients share bank"
|
||||
(bank-ev
|
||||
(str
|
||||
er-bank-server-src
|
||||
", Me = self(),
|
||||
Bank = spawn(fun () -> Server(0) end),
|
||||
Client = fun (Amt) ->
|
||||
spawn(fun () ->
|
||||
Bank ! {deposit, Amt, self()},
|
||||
receive ok -> Me ! deposited end
|
||||
end)
|
||||
end,
|
||||
Client(40),
|
||||
Client(60),
|
||||
receive deposited -> ok end,
|
||||
receive deposited -> ok end,
|
||||
Bank ! {balance, Me},
|
||||
receive B -> Bank ! stop, B end"))
|
||||
100)
|
||||
|
||||
(define
|
||||
er-bank-test-summary
|
||||
(str "bank " er-bank-test-pass "/" er-bank-test-count))
|
||||
140
lib/erlang/tests/programs/echo.sx
Normal file
140
lib/erlang/tests/programs/echo.sx
Normal file
@@ -0,0 +1,140 @@
|
||||
;; Echo server — minimal classic Erlang server. Receives {From, Msg}
|
||||
;; and sends Msg back to From, then loops. `stop` ends the server.
|
||||
|
||||
(define er-echo-test-count 0)
|
||||
(define er-echo-test-pass 0)
|
||||
(define er-echo-test-fails (list))
|
||||
|
||||
(define
|
||||
er-echo-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! er-echo-test-count (+ er-echo-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! er-echo-test-pass (+ er-echo-test-pass 1))
|
||||
(append! er-echo-test-fails {:actual actual :expected expected :name name}))))
|
||||
|
||||
(define echo-ev erlang-eval-ast)
|
||||
|
||||
(define
|
||||
er-echo-server-src
|
||||
"EchoSrv = fun () ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{From, Msg} -> From ! Msg, Loop();
|
||||
stop -> ok
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end")
|
||||
|
||||
;; Single round-trip with an atom.
|
||||
(er-echo-test
|
||||
"atom round-trip"
|
||||
(get
|
||||
(echo-ev
|
||||
(str
|
||||
er-echo-server-src
|
||||
", Me = self(),
|
||||
Echo = spawn(EchoSrv),
|
||||
Echo ! {Me, hello},
|
||||
receive R -> Echo ! stop, R end"))
|
||||
:name)
|
||||
"hello")
|
||||
|
||||
;; Number round-trip.
|
||||
(er-echo-test
|
||||
"number round-trip"
|
||||
(echo-ev
|
||||
(str
|
||||
er-echo-server-src
|
||||
", Me = self(),
|
||||
Echo = spawn(EchoSrv),
|
||||
Echo ! {Me, 42},
|
||||
receive R -> Echo ! stop, R end"))
|
||||
42)
|
||||
|
||||
;; Tuple round-trip — pattern-match the reply to extract V.
|
||||
(er-echo-test
|
||||
"tuple round-trip"
|
||||
(echo-ev
|
||||
(str
|
||||
er-echo-server-src
|
||||
", Me = self(),
|
||||
Echo = spawn(EchoSrv),
|
||||
Echo ! {Me, {ok, 7}},
|
||||
receive {ok, V} -> Echo ! stop, V end"))
|
||||
7)
|
||||
|
||||
;; List round-trip.
|
||||
(er-echo-test
|
||||
"list round-trip"
|
||||
(echo-ev
|
||||
(str
|
||||
er-echo-server-src
|
||||
", Me = self(),
|
||||
Echo = spawn(EchoSrv),
|
||||
Echo ! {Me, [1, 2, 3]},
|
||||
receive [H | _] -> Echo ! stop, H end"))
|
||||
1)
|
||||
|
||||
;; Multiple sequential round-trips.
|
||||
(er-echo-test
|
||||
"three round-trips"
|
||||
(echo-ev
|
||||
(str
|
||||
er-echo-server-src
|
||||
", Me = self(),
|
||||
Echo = spawn(EchoSrv),
|
||||
Echo ! {Me, 10}, A = receive Ra -> Ra end,
|
||||
Echo ! {Me, 20}, B = receive Rb -> Rb end,
|
||||
Echo ! {Me, 30}, C = receive Rc -> Rc end,
|
||||
Echo ! stop,
|
||||
A + B + C"))
|
||||
60)
|
||||
|
||||
;; Two clients sharing one echo server. Each gets its own reply.
|
||||
(er-echo-test
|
||||
"two clients"
|
||||
(get
|
||||
(echo-ev
|
||||
(str
|
||||
er-echo-server-src
|
||||
", Me = self(),
|
||||
Echo = spawn(EchoSrv),
|
||||
Client = fun (Tag) ->
|
||||
spawn(fun () ->
|
||||
Echo ! {self(), Tag},
|
||||
receive R -> Me ! {got, R} end
|
||||
end)
|
||||
end,
|
||||
Client(a),
|
||||
Client(b),
|
||||
receive {got, _} -> ok end,
|
||||
receive {got, _} -> ok end,
|
||||
Echo ! stop,
|
||||
finished"))
|
||||
:name)
|
||||
"finished")
|
||||
|
||||
;; Echo via io trace — verify each message round-trips through.
|
||||
(er-echo-test
|
||||
"trace 4 messages"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(echo-ev
|
||||
(str
|
||||
er-echo-server-src
|
||||
", Me = self(),
|
||||
Echo = spawn(EchoSrv),
|
||||
Send = fun (V) -> Echo ! {Me, V}, receive R -> io:format(\"~p \", [R]) end end,
|
||||
Send(1), Send(2), Send(3), Send(4),
|
||||
Echo ! stop,
|
||||
done"))
|
||||
(er-io-buffer-content))
|
||||
"1 2 3 4 ")
|
||||
|
||||
(define
|
||||
er-echo-test-summary
|
||||
(str "echo " er-echo-test-pass "/" er-echo-test-count))
|
||||
152
lib/erlang/tests/programs/fib_server.sx
Normal file
152
lib/erlang/tests/programs/fib_server.sx
Normal file
@@ -0,0 +1,152 @@
|
||||
;; Fib server — long-lived process that computes fibonacci numbers on
|
||||
;; request. Tests recursive function evaluation inside a server loop.
|
||||
|
||||
(define er-fib-test-count 0)
|
||||
(define er-fib-test-pass 0)
|
||||
(define er-fib-test-fails (list))
|
||||
|
||||
(define
|
||||
er-fib-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! er-fib-test-count (+ er-fib-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! er-fib-test-pass (+ er-fib-test-pass 1))
|
||||
(append! er-fib-test-fails {:actual actual :expected expected :name name}))))
|
||||
|
||||
(define fib-ev erlang-eval-ast)
|
||||
|
||||
;; Fib + server-loop source. Standalone so each test can chain queries.
|
||||
(define
|
||||
er-fib-server-src
|
||||
"Fib = fun (0) -> 0; (1) -> 1; (N) -> Fib(N-1) + Fib(N-2) end,
|
||||
FibSrv = fun () ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{fib, N, From} -> From ! Fib(N), Loop();
|
||||
stop -> ok
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end")
|
||||
|
||||
;; Base cases.
|
||||
(er-fib-test
|
||||
"fib(0)"
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Srv ! {fib, 0, Me},
|
||||
receive R -> Srv ! stop, R end"))
|
||||
0)
|
||||
|
||||
(er-fib-test
|
||||
"fib(1)"
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Srv ! {fib, 1, Me},
|
||||
receive R -> Srv ! stop, R end"))
|
||||
1)
|
||||
|
||||
;; Larger values.
|
||||
(er-fib-test
|
||||
"fib(10) = 55"
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Srv ! {fib, 10, Me},
|
||||
receive R -> Srv ! stop, R end"))
|
||||
55)
|
||||
|
||||
(er-fib-test
|
||||
"fib(15) = 610"
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Srv ! {fib, 15, Me},
|
||||
receive R -> Srv ! stop, R end"))
|
||||
610)
|
||||
|
||||
;; Multiple sequential queries to one server. Sum to avoid dict-equality.
|
||||
(er-fib-test
|
||||
"sequential fib(5..8) sum"
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Srv ! {fib, 5, Me}, A = receive Ra -> Ra end,
|
||||
Srv ! {fib, 6, Me}, B = receive Rb -> Rb end,
|
||||
Srv ! {fib, 7, Me}, C = receive Rc -> Rc end,
|
||||
Srv ! {fib, 8, Me}, D = receive Rd -> Rd end,
|
||||
Srv ! stop,
|
||||
A + B + C + D"))
|
||||
47)
|
||||
|
||||
;; Verify Fib obeys the recurrence — fib(n) = fib(n-1) + fib(n-2).
|
||||
(er-fib-test
|
||||
"fib recurrence at n=12"
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Srv ! {fib, 10, Me}, A = receive Ra -> Ra end,
|
||||
Srv ! {fib, 11, Me}, B = receive Rb -> Rb end,
|
||||
Srv ! {fib, 12, Me}, C = receive Rc -> Rc end,
|
||||
Srv ! stop,
|
||||
C - (A + B)"))
|
||||
0)
|
||||
|
||||
;; Two clients each get their own answer; main sums the results.
|
||||
(er-fib-test
|
||||
"two clients sum"
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Client = fun (N) ->
|
||||
spawn(fun () ->
|
||||
Srv ! {fib, N, self()},
|
||||
receive R -> Me ! {result, R} end
|
||||
end)
|
||||
end,
|
||||
Client(7),
|
||||
Client(9),
|
||||
{result, A} = receive M1 -> M1 end,
|
||||
{result, B} = receive M2 -> M2 end,
|
||||
Srv ! stop,
|
||||
A + B"))
|
||||
47)
|
||||
|
||||
;; Trace queries via io-buffer.
|
||||
(er-fib-test
|
||||
"trace fib 0..6"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(fib-ev
|
||||
(str
|
||||
er-fib-server-src
|
||||
", Me = self(),
|
||||
Srv = spawn(FibSrv),
|
||||
Ask = fun (N) -> Srv ! {fib, N, Me}, receive R -> io:format(\"~p \", [R]) end end,
|
||||
Ask(0), Ask(1), Ask(2), Ask(3), Ask(4), Ask(5), Ask(6),
|
||||
Srv ! stop,
|
||||
done"))
|
||||
(er-io-buffer-content))
|
||||
"0 1 1 2 3 5 8 ")
|
||||
|
||||
(define
|
||||
er-fib-test-summary
|
||||
(str "fib " er-fib-test-pass "/" er-fib-test-count))
|
||||
127
lib/erlang/tests/programs/ping_pong.sx
Normal file
127
lib/erlang/tests/programs/ping_pong.sx
Normal file
@@ -0,0 +1,127 @@
|
||||
;; Ping-pong program — two processes exchange N messages, then signal
|
||||
;; main via separate `ping_done` / `pong_done` notifications.
|
||||
|
||||
(define er-pp-test-count 0)
|
||||
(define er-pp-test-pass 0)
|
||||
(define er-pp-test-fails (list))
|
||||
|
||||
(define
|
||||
er-pp-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! er-pp-test-count (+ er-pp-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! er-pp-test-pass (+ er-pp-test-pass 1))
|
||||
(append! er-pp-test-fails {:actual actual :expected expected :name name}))))
|
||||
|
||||
(define pp-ev erlang-eval-ast)
|
||||
|
||||
;; Three rounds of ping-pong, then stop. Main receives ping_done and
|
||||
;; pong_done in arrival order (Ping finishes first because Pong exits
|
||||
;; only after receiving stop).
|
||||
(define
|
||||
er-pp-program
|
||||
"Me = self(),
|
||||
Pong = spawn(fun () ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{ping, From} -> From ! pong, Loop();
|
||||
stop -> Me ! pong_done
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end),
|
||||
Ping = fun (Target, K) ->
|
||||
if K =:= 0 -> Target ! stop, Me ! ping_done;
|
||||
true -> Target ! {ping, self()}, receive pong -> Ping(Target, K - 1) end
|
||||
end
|
||||
end,
|
||||
spawn(fun () -> Ping(Pong, 3) end),
|
||||
receive ping_done -> ok end,
|
||||
receive pong_done -> both_done end")
|
||||
|
||||
(er-pp-test
|
||||
"ping-pong 3 rounds"
|
||||
(get (pp-ev er-pp-program) :name)
|
||||
"both_done")
|
||||
|
||||
;; Count exchanges via io-buffer — each pong trip prints "p".
|
||||
(er-pp-test
|
||||
"ping-pong 5 rounds trace"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(pp-ev
|
||||
"Me = self(),
|
||||
Pong = spawn(fun () ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{ping, From} -> io:format(\"p\"), From ! pong, Loop();
|
||||
stop -> Me ! pong_done
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end),
|
||||
Ping = fun (Target, K) ->
|
||||
if K =:= 0 -> Target ! stop, Me ! ping_done;
|
||||
true -> Target ! {ping, self()}, receive pong -> Ping(Target, K - 1) end
|
||||
end
|
||||
end,
|
||||
spawn(fun () -> Ping(Pong, 5) end),
|
||||
receive ping_done -> ok end,
|
||||
receive pong_done -> ok end")
|
||||
(er-io-buffer-content))
|
||||
"ppppp")
|
||||
|
||||
;; Main → Pong directly (no Ping process). Main plays the ping role.
|
||||
(er-pp-test
|
||||
"main-as-pinger 4 rounds"
|
||||
(pp-ev
|
||||
"Me = self(),
|
||||
Pong = spawn(fun () ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{ping, From} -> From ! pong, Loop();
|
||||
stop -> ok
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end),
|
||||
Go = fun (K) ->
|
||||
if K =:= 0 -> Pong ! stop, K;
|
||||
true -> Pong ! {ping, Me}, receive pong -> Go(K - 1) end
|
||||
end
|
||||
end,
|
||||
Go(4)")
|
||||
0)
|
||||
|
||||
;; Ensure the processes really interleave — inject an id into each
|
||||
;; ping and check we get them all back via trace (the order is
|
||||
;; deterministic under our sync scheduler).
|
||||
(er-pp-test
|
||||
"ids round-trip"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(pp-ev
|
||||
"Me = self(),
|
||||
Pong = spawn(fun () ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{ping, From, Id} -> From ! {pong, Id}, Loop();
|
||||
stop -> ok
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end),
|
||||
Go = fun (K) ->
|
||||
if K =:= 0 -> Pong ! stop, done;
|
||||
true -> Pong ! {ping, Me, K}, receive {pong, RId} -> io:format(\"~p \", [RId]), Go(K - 1) end
|
||||
end
|
||||
end,
|
||||
Go(4)")
|
||||
(er-io-buffer-content))
|
||||
"4 3 2 1 ")
|
||||
|
||||
(define
|
||||
er-pp-test-summary
|
||||
(str "ping-pong " er-pp-test-pass "/" er-pp-test-count))
|
||||
132
lib/erlang/tests/programs/ring.sx
Normal file
132
lib/erlang/tests/programs/ring.sx
Normal file
@@ -0,0 +1,132 @@
|
||||
;; Ring program — N processes in a ring, token passes M times.
|
||||
;;
|
||||
;; Each process waits for {setup, Next} so main can tie the knot
|
||||
;; (can't reference a pid before spawning it). Once wired, main
|
||||
;; injects the first token; each process forwards decrementing K
|
||||
;; until it hits 0, at which point it signals `done` to main.
|
||||
|
||||
(define er-ring-test-count 0)
|
||||
(define er-ring-test-pass 0)
|
||||
(define er-ring-test-fails (list))
|
||||
|
||||
(define
|
||||
er-ring-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! er-ring-test-count (+ er-ring-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! er-ring-test-pass (+ er-ring-test-pass 1))
|
||||
(append! er-ring-test-fails {:actual actual :expected expected :name name}))))
|
||||
|
||||
(define ring-ev erlang-eval-ast)
|
||||
|
||||
(define
|
||||
er-ring-program-3-6
|
||||
"Me = self(),
|
||||
Spawner = fun () ->
|
||||
receive {setup, Next} ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{token, 0, Parent} -> Parent ! done;
|
||||
{token, K, Parent} -> Next ! {token, K-1, Parent}, Loop()
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end
|
||||
end,
|
||||
P1 = spawn(Spawner),
|
||||
P2 = spawn(Spawner),
|
||||
P3 = spawn(Spawner),
|
||||
P1 ! {setup, P2},
|
||||
P2 ! {setup, P3},
|
||||
P3 ! {setup, P1},
|
||||
P1 ! {token, 5, Me},
|
||||
receive done -> finished end")
|
||||
|
||||
(er-ring-test
|
||||
"ring N=3 M=6"
|
||||
(get (ring-ev er-ring-program-3-6) :name)
|
||||
"finished")
|
||||
|
||||
;; Two-node ring — token bounces twice between P1 and P2.
|
||||
(er-ring-test
|
||||
"ring N=2 M=4"
|
||||
(get (ring-ev
|
||||
"Me = self(),
|
||||
Spawner = fun () ->
|
||||
receive {setup, Next} ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{token, 0, Parent} -> Parent ! done;
|
||||
{token, K, Parent} -> Next ! {token, K-1, Parent}, Loop()
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end
|
||||
end,
|
||||
P1 = spawn(Spawner),
|
||||
P2 = spawn(Spawner),
|
||||
P1 ! {setup, P2},
|
||||
P2 ! {setup, P1},
|
||||
P1 ! {token, 3, Me},
|
||||
receive done -> done end") :name)
|
||||
"done")
|
||||
|
||||
;; Single-node "ring" — P sends to itself M times.
|
||||
(er-ring-test
|
||||
"ring N=1 M=5"
|
||||
(get (ring-ev
|
||||
"Me = self(),
|
||||
Spawner = fun () ->
|
||||
receive {setup, Next} ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{token, 0, Parent} -> Parent ! finished_loop;
|
||||
{token, K, Parent} -> Next ! {token, K-1, Parent}, Loop()
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end
|
||||
end,
|
||||
P = spawn(Spawner),
|
||||
P ! {setup, P},
|
||||
P ! {token, 4, Me},
|
||||
receive finished_loop -> ok end") :name)
|
||||
"ok")
|
||||
|
||||
;; Confirm the token really went around — count hops via io-buffer.
|
||||
(er-ring-test
|
||||
"ring N=3 M=9 hop count"
|
||||
(do
|
||||
(er-io-flush!)
|
||||
(ring-ev
|
||||
"Me = self(),
|
||||
Spawner = fun () ->
|
||||
receive {setup, Next} ->
|
||||
Loop = fun () ->
|
||||
receive
|
||||
{token, 0, Parent} -> Parent ! done;
|
||||
{token, K, Parent} ->
|
||||
io:format(\"~p \", [K]),
|
||||
Next ! {token, K-1, Parent},
|
||||
Loop()
|
||||
end
|
||||
end,
|
||||
Loop()
|
||||
end
|
||||
end,
|
||||
P1 = spawn(Spawner),
|
||||
P2 = spawn(Spawner),
|
||||
P3 = spawn(Spawner),
|
||||
P1 ! {setup, P2},
|
||||
P2 ! {setup, P3},
|
||||
P3 ! {setup, P1},
|
||||
P1 ! {token, 8, Me},
|
||||
receive done -> done end")
|
||||
(er-io-buffer-content))
|
||||
"8 7 6 5 4 3 2 1 ")
|
||||
|
||||
(define
|
||||
er-ring-test-summary
|
||||
(str "ring " er-ring-test-pass "/" er-ring-test-count))
|
||||
139
lib/erlang/tests/runtime.sx
Normal file
139
lib/erlang/tests/runtime.sx
Normal file
@@ -0,0 +1,139 @@
|
||||
;; Erlang runtime tests — scheduler + process-record primitives.
|
||||
|
||||
(define er-rt-test-count 0)
|
||||
(define er-rt-test-pass 0)
|
||||
(define er-rt-test-fails (list))
|
||||
|
||||
(define
|
||||
er-rt-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! er-rt-test-count (+ er-rt-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! er-rt-test-pass (+ er-rt-test-pass 1))
|
||||
(append! er-rt-test-fails {:actual actual :expected expected :name name}))))
|
||||
|
||||
;; ── queue ─────────────────────────────────────────────────────────
|
||||
(er-rt-test "queue empty len" (er-q-len (er-q-new)) 0)
|
||||
(er-rt-test "queue empty?" (er-q-empty? (er-q-new)) true)
|
||||
|
||||
(define q1 (er-q-new))
|
||||
(er-q-push! q1 "a")
|
||||
(er-q-push! q1 "b")
|
||||
(er-q-push! q1 "c")
|
||||
(er-rt-test "queue push len" (er-q-len q1) 3)
|
||||
(er-rt-test "queue empty? after push" (er-q-empty? q1) false)
|
||||
(er-rt-test "queue peek" (er-q-peek q1) "a")
|
||||
(er-rt-test "queue pop 1" (er-q-pop! q1) "a")
|
||||
(er-rt-test "queue pop 2" (er-q-pop! q1) "b")
|
||||
(er-rt-test "queue len after pops" (er-q-len q1) 1)
|
||||
(er-rt-test "queue pop 3" (er-q-pop! q1) "c")
|
||||
(er-rt-test "queue empty again" (er-q-empty? q1) true)
|
||||
(er-rt-test "queue pop empty" (er-q-pop! q1) nil)
|
||||
|
||||
;; Queue FIFO under interleaved push/pop
|
||||
(define q2 (er-q-new))
|
||||
(er-q-push! q2 1)
|
||||
(er-q-push! q2 2)
|
||||
(er-q-pop! q2)
|
||||
(er-q-push! q2 3)
|
||||
(er-rt-test "queue interleave peek" (er-q-peek q2) 2)
|
||||
(er-rt-test "queue to-list" (er-q-to-list q2) (list 2 3))
|
||||
|
||||
;; ── scheduler init ─────────────────────────────────────────────
|
||||
(er-sched-init!)
|
||||
(er-rt-test "sched process count 0" (er-sched-process-count) 0)
|
||||
(er-rt-test "sched runnable count 0" (er-sched-runnable-count) 0)
|
||||
(er-rt-test "sched current nil" (er-sched-current-pid) nil)
|
||||
|
||||
;; ── pid allocation ─────────────────────────────────────────────
|
||||
(define pa (er-pid-new!))
|
||||
(define pb (er-pid-new!))
|
||||
(er-rt-test "pid tag" (get pa :tag) "pid")
|
||||
(er-rt-test "pid ids distinct" (= (er-pid-id pa) (er-pid-id pb)) false)
|
||||
(er-rt-test "pid? true" (er-pid? pa) true)
|
||||
(er-rt-test "pid? false" (er-pid? 42) false)
|
||||
(er-rt-test
|
||||
"pid-equal same"
|
||||
(er-pid-equal? pa (er-mk-pid (er-pid-id pa)))
|
||||
true)
|
||||
(er-rt-test "pid-equal diff" (er-pid-equal? pa pb) false)
|
||||
|
||||
;; ── process lifecycle ──────────────────────────────────────────
|
||||
(er-sched-init!)
|
||||
(define p1 (er-proc-new! {}))
|
||||
(define p2 (er-proc-new! {}))
|
||||
(er-rt-test "proc count 2" (er-sched-process-count) 2)
|
||||
(er-rt-test "runnable count 2" (er-sched-runnable-count) 2)
|
||||
(er-rt-test
|
||||
"proc state runnable"
|
||||
(er-proc-field (get p1 :pid) :state)
|
||||
"runnable")
|
||||
(er-rt-test
|
||||
"proc mailbox empty"
|
||||
(er-proc-mailbox-size (get p1 :pid))
|
||||
0)
|
||||
(er-rt-test
|
||||
"proc lookup"
|
||||
(er-pid-equal? (get (er-proc-get (get p1 :pid)) :pid) (get p1 :pid))
|
||||
true)
|
||||
(er-rt-test "proc exists" (er-proc-exists? (get p1 :pid)) true)
|
||||
(er-rt-test
|
||||
"proc no-such-pid"
|
||||
(er-proc-exists? (er-mk-pid 9999))
|
||||
false)
|
||||
|
||||
;; runnable queue dequeue order
|
||||
(er-rt-test
|
||||
"dequeue first"
|
||||
(er-pid-equal? (er-sched-next-runnable!) (get p1 :pid))
|
||||
true)
|
||||
(er-rt-test
|
||||
"dequeue second"
|
||||
(er-pid-equal? (er-sched-next-runnable!) (get p2 :pid))
|
||||
true)
|
||||
(er-rt-test "dequeue empty" (er-sched-next-runnable!) nil)
|
||||
|
||||
;; current-pid get/set
|
||||
(er-sched-set-current! (get p1 :pid))
|
||||
(er-rt-test
|
||||
"current pid set"
|
||||
(er-pid-equal? (er-sched-current-pid) (get p1 :pid))
|
||||
true)
|
||||
|
||||
;; ── mailbox push ──────────────────────────────────────────────
|
||||
(er-proc-mailbox-push! (get p1 :pid) {:tag "atom" :name "ping"})
|
||||
(er-proc-mailbox-push! (get p1 :pid) 42)
|
||||
(er-rt-test "mailbox size 2" (er-proc-mailbox-size (get p1 :pid)) 2)
|
||||
|
||||
;; ── field update ──────────────────────────────────────────────
|
||||
(er-proc-set! (get p1 :pid) :state "waiting")
|
||||
(er-rt-test
|
||||
"proc state waiting"
|
||||
(er-proc-field (get p1 :pid) :state)
|
||||
"waiting")
|
||||
(er-proc-set! (get p1 :pid) :trap-exit true)
|
||||
(er-rt-test
|
||||
"proc trap-exit"
|
||||
(er-proc-field (get p1 :pid) :trap-exit)
|
||||
true)
|
||||
|
||||
;; ── fresh scheduler ends in clean state ───────────────────────
|
||||
(er-sched-init!)
|
||||
(er-rt-test
|
||||
"sched init resets count"
|
||||
(er-sched-process-count)
|
||||
0)
|
||||
(er-rt-test
|
||||
"sched init resets queue"
|
||||
(er-sched-runnable-count)
|
||||
0)
|
||||
(er-rt-test
|
||||
"sched init resets current"
|
||||
(er-sched-current-pid)
|
||||
nil)
|
||||
|
||||
(define
|
||||
er-rt-test-summary
|
||||
(str "runtime " er-rt-test-pass "/" er-rt-test-count))
|
||||
1090
lib/erlang/transpile.sx
Normal file
1090
lib/erlang/transpile.sx
Normal file
File diff suppressed because it is too large
Load Diff
@@ -1,249 +0,0 @@
|
||||
;; Desugar the Haskell surface AST into a smaller core AST.
|
||||
;;
|
||||
;; Eliminates the three surface-only shapes produced by the parser:
|
||||
;; :where BODY DECLS → :let DECLS BODY
|
||||
;; :guarded GUARDS → :if C1 E1 (:if C2 E2 … (:app error …))
|
||||
;; :list-comp EXPR QUALS → concatMap-based expression (§3.11)
|
||||
;;
|
||||
;; Everything else (:app, :op, :lambda, :let, :case, :do, :tuple,
|
||||
;; :list, :range, :if, :neg, :sect-left / :sect-right, plus all
|
||||
;; leaf forms and pattern / type nodes) is passed through after
|
||||
;; recursing into children.
|
||||
|
||||
(define
|
||||
hk-guards-to-if
|
||||
(fn
|
||||
(guards)
|
||||
(cond
|
||||
((empty? guards)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards")))
|
||||
(:else
|
||||
(let
|
||||
((g (first guards)))
|
||||
(list
|
||||
:if
|
||||
(hk-desugar (nth g 1))
|
||||
(hk-desugar (nth g 2))
|
||||
(hk-guards-to-if (rest guards))))))))
|
||||
|
||||
;; do-notation desugaring (Haskell 98 §3.14):
|
||||
;; do { e } = e
|
||||
;; do { e ; ss } = e >> do { ss }
|
||||
;; do { p <- e ; ss } = e >>= \p -> do { ss }
|
||||
;; do { let decls ; ss } = let decls in do { ss }
|
||||
(define
|
||||
hk-desugar-do
|
||||
(fn
|
||||
(stmts)
|
||||
(cond
|
||||
((empty? stmts) (raise "empty do block"))
|
||||
((empty? (rest stmts))
|
||||
(let ((s (first stmts)))
|
||||
(cond
|
||||
((= (first s) "do-expr") (hk-desugar (nth s 1)))
|
||||
(:else
|
||||
(raise "do block must end with an expression")))))
|
||||
(:else
|
||||
(let
|
||||
((s (first stmts)) (rest-stmts (rest stmts)))
|
||||
(let
|
||||
((rest-do (hk-desugar-do rest-stmts)))
|
||||
(cond
|
||||
((= (first s) "do-expr")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var ">>")
|
||||
(hk-desugar (nth s 1)))
|
||||
rest-do))
|
||||
((= (first s) "do-bind")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var ">>=")
|
||||
(hk-desugar (nth s 2)))
|
||||
(list :lambda (list (nth s 1)) rest-do)))
|
||||
((= (first s) "do-let")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth s 1))
|
||||
rest-do))
|
||||
(:else (raise "unknown do-stmt tag")))))))))
|
||||
|
||||
;; List-comprehension desugaring (Haskell 98 §3.11):
|
||||
;; [e | ] = [e]
|
||||
;; [e | b, Q ] = if b then [e | Q] else []
|
||||
;; [e | p <- l, Q ] = concatMap (\p -> [e | Q]) l
|
||||
;; [e | let ds, Q ] = let ds in [e | Q]
|
||||
(define
|
||||
hk-lc-desugar
|
||||
(fn
|
||||
(e quals)
|
||||
(cond
|
||||
((empty? quals) (list :list (list e)))
|
||||
(:else
|
||||
(let
|
||||
((q (first quals)))
|
||||
(let
|
||||
((qtag (first q)))
|
||||
(cond
|
||||
((= qtag "q-guard")
|
||||
(list
|
||||
:if
|
||||
(hk-desugar (nth q 1))
|
||||
(hk-lc-desugar e (rest quals))
|
||||
(list :list (list))))
|
||||
((= qtag "q-gen")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (nth q 1))
|
||||
(hk-lc-desugar e (rest quals))))
|
||||
(hk-desugar (nth q 2))))
|
||||
((= qtag "q-let")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth q 1))
|
||||
(hk-lc-desugar e (rest quals))))
|
||||
(:else
|
||||
(raise
|
||||
(str
|
||||
"hk-lc-desugar: unknown qualifier tag "
|
||||
qtag))))))))))
|
||||
|
||||
(define
|
||||
hk-desugar
|
||||
(fn
|
||||
(node)
|
||||
(cond
|
||||
((not (list? node)) node)
|
||||
((empty? node) node)
|
||||
(:else
|
||||
(let
|
||||
((tag (first node)))
|
||||
(cond
|
||||
;; Transformations
|
||||
((= tag "where")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 1))))
|
||||
((= tag "guarded") (hk-guards-to-if (nth node 1)))
|
||||
((= tag "list-comp")
|
||||
(hk-lc-desugar
|
||||
(hk-desugar (nth node 1))
|
||||
(nth node 2)))
|
||||
|
||||
;; Expression nodes
|
||||
((= tag "app")
|
||||
(list
|
||||
:app
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "op")
|
||||
(list
|
||||
:op
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
||||
((= tag "if")
|
||||
(list
|
||||
:if
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "tuple")
|
||||
(list :tuple (map hk-desugar (nth node 1))))
|
||||
((= tag "list")
|
||||
(list :list (map hk-desugar (nth node 1))))
|
||||
((= tag "range")
|
||||
(list
|
||||
:range
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "range-step")
|
||||
(list
|
||||
:range-step
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "lambda")
|
||||
(list
|
||||
:lambda
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "let")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "case")
|
||||
(list
|
||||
:case
|
||||
(hk-desugar (nth node 1))
|
||||
(map hk-desugar (nth node 2))))
|
||||
((= tag "alt")
|
||||
(list :alt (nth node 1) (hk-desugar (nth node 2))))
|
||||
((= tag "do") (hk-desugar-do (nth node 1)))
|
||||
((= tag "sect-left")
|
||||
(list
|
||||
:sect-left
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "sect-right")
|
||||
(list
|
||||
:sect-right
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
|
||||
;; Top-level
|
||||
((= tag "program")
|
||||
(list :program (map hk-desugar (nth node 1))))
|
||||
((= tag "module")
|
||||
(list
|
||||
:module
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(nth node 3)
|
||||
(map hk-desugar (nth node 4))))
|
||||
|
||||
;; Decls carrying a body
|
||||
((= tag "fun-clause")
|
||||
(list
|
||||
:fun-clause
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "pat-bind")
|
||||
(list
|
||||
:pat-bind
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "bind")
|
||||
(list
|
||||
:bind
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
|
||||
;; Everything else: leaf literals, vars, cons, patterns,
|
||||
;; types, imports, type-sigs, data / newtype / fixity, …
|
||||
(:else node)))))))
|
||||
|
||||
;; Convenience — tokenize + layout + parse + desugar.
|
||||
(define
|
||||
hk-core
|
||||
(fn (src) (hk-desugar (hk-parse-top src))))
|
||||
|
||||
(define
|
||||
hk-core-expr
|
||||
(fn (src) (hk-desugar (hk-parse src))))
|
||||
@@ -1,775 +0,0 @@
|
||||
;; Haskell strict evaluator (Phase 2).
|
||||
;;
|
||||
;; Consumes the post-desugar core AST and produces SX values. Strict
|
||||
;; throughout — laziness and thunks are Phase 3.
|
||||
;;
|
||||
;; Value representation:
|
||||
;; numbers / strings / chars → raw SX values
|
||||
;; constructor values → tagged lists (con-name first)
|
||||
;; functions: closure / multifun → {:type "fn" :kind … …}
|
||||
;; constructor partials → {:type "con-partial" …}
|
||||
;; built-ins → {:type "builtin" …}
|
||||
;;
|
||||
;; Multi-clause top-level definitions are bundled into a single
|
||||
;; multifun keyed by name; arguments are gathered through currying
|
||||
;; until arity is reached, then each clause's pattern list is matched
|
||||
;; in order. Recursive let bindings work because the binding env is
|
||||
;; built mutably so closures captured during evaluation see the
|
||||
;; eventual full env.
|
||||
|
||||
(define
|
||||
hk-dict-copy
|
||||
(fn
|
||||
(d)
|
||||
(let ((nd (dict)))
|
||||
(for-each
|
||||
(fn (k) (dict-set! nd k (get d k)))
|
||||
(keys d))
|
||||
nd)))
|
||||
|
||||
;; ── Thunks (Phase 3 — laziness) ─────────────────────────────
|
||||
;; A thunk wraps an unevaluated AST plus the env in which it was
|
||||
;; created. The first call to `hk-force` evaluates the body, replaces
|
||||
;; the body with the cached value, and flips `forced`. Subsequent
|
||||
;; forces return the cached value directly.
|
||||
(define
|
||||
hk-mk-thunk
|
||||
(fn
|
||||
(body env)
|
||||
{:type "thunk" :body body :env env :forced false :value nil}))
|
||||
|
||||
(define
|
||||
hk-is-thunk?
|
||||
(fn (v) (and (dict? v) (= (get v "type") "thunk"))))
|
||||
|
||||
(define
|
||||
hk-force
|
||||
(fn
|
||||
(v)
|
||||
(cond
|
||||
((hk-is-thunk? v)
|
||||
(cond
|
||||
((get v "forced") (get v "value"))
|
||||
(:else
|
||||
(let
|
||||
((res (hk-force (hk-eval (get v "body") (get v "env")))))
|
||||
(dict-set! v "forced" true)
|
||||
(dict-set! v "value" res)
|
||||
res))))
|
||||
(:else v))))
|
||||
|
||||
;; Recursive force — used at the test/output boundary so test
|
||||
;; expectations can compare against fully-evaluated structures.
|
||||
(define
|
||||
hk-deep-force
|
||||
(fn
|
||||
(v)
|
||||
(let ((fv (hk-force v)))
|
||||
(cond
|
||||
((not (list? fv)) fv)
|
||||
((empty? fv) fv)
|
||||
(:else (map hk-deep-force fv))))))
|
||||
|
||||
;; ── Function value constructors ──────────────────────────────
|
||||
(define
|
||||
hk-mk-closure
|
||||
(fn
|
||||
(params body env)
|
||||
{:type "fn" :kind "closure" :params params :body body :env env}))
|
||||
|
||||
(define
|
||||
hk-mk-multifun
|
||||
(fn
|
||||
(arity clauses env)
|
||||
{:type "fn" :kind "multi" :arity arity :clauses clauses :env env :collected (list)}))
|
||||
|
||||
(define
|
||||
hk-mk-builtin
|
||||
(fn
|
||||
(name fn arity)
|
||||
{:type "builtin" :name name :fn fn :arity arity :lazy false :collected (list)}))
|
||||
|
||||
;; A lazy built-in receives its collected args as raw thunks (or
|
||||
;; values, if those happened to be eager) — the implementation is
|
||||
;; responsible for forcing exactly what it needs. Used for `seq`
|
||||
;; and `deepseq`, which are non-strict in their second argument.
|
||||
(define
|
||||
hk-mk-lazy-builtin
|
||||
(fn
|
||||
(name fn arity)
|
||||
{:type "builtin" :name name :fn fn :arity arity :lazy true :collected (list)}))
|
||||
|
||||
;; ── Apply a function value to one argument ──────────────────
|
||||
(define
|
||||
hk-apply
|
||||
(fn
|
||||
(f arg)
|
||||
(let ((f (hk-force f)))
|
||||
(cond
|
||||
((not (dict? f))
|
||||
(raise (str "apply: not a function value: " f)))
|
||||
((= (get f "type") "fn")
|
||||
(cond
|
||||
((= (get f "kind") "closure") (hk-apply-closure f arg))
|
||||
((= (get f "kind") "multi") (hk-apply-multi f arg))
|
||||
(:else (raise "apply: unknown fn kind"))))
|
||||
((= (get f "type") "con-partial") (hk-apply-con-partial f arg))
|
||||
((= (get f "type") "builtin") (hk-apply-builtin f arg))
|
||||
(:else (raise "apply: not a function dict"))))))
|
||||
|
||||
(define
|
||||
hk-apply-closure
|
||||
(fn
|
||||
(cl arg)
|
||||
(let
|
||||
((params (get cl "params"))
|
||||
(body (get cl "body"))
|
||||
(env (get cl "env")))
|
||||
(cond
|
||||
((empty? params) (raise "apply-closure: no params"))
|
||||
(:else
|
||||
(let
|
||||
((p1 (first params)) (rest-p (rest params)))
|
||||
(let
|
||||
((env-after (hk-match p1 arg env)))
|
||||
(cond
|
||||
((nil? env-after)
|
||||
(raise "pattern match failure in lambda"))
|
||||
((empty? rest-p) (hk-eval body env-after))
|
||||
(:else
|
||||
(hk-mk-closure rest-p body env-after))))))))))
|
||||
|
||||
(define
|
||||
hk-apply-multi
|
||||
(fn
|
||||
(mf arg)
|
||||
(let
|
||||
((arity (get mf "arity"))
|
||||
(clauses (get mf "clauses"))
|
||||
(env (get mf "env"))
|
||||
(collected (append (get mf "collected") (list arg))))
|
||||
(cond
|
||||
((< (len collected) arity)
|
||||
(assoc mf "collected" collected))
|
||||
(:else (hk-dispatch-multi clauses collected env))))))
|
||||
|
||||
(define
|
||||
hk-dispatch-multi
|
||||
(fn
|
||||
(clauses args env)
|
||||
(cond
|
||||
((empty? clauses)
|
||||
(raise "non-exhaustive patterns in function definition"))
|
||||
(:else
|
||||
(let
|
||||
((c (first clauses)))
|
||||
(let
|
||||
((pats (first c)) (body (first (rest c))))
|
||||
(let
|
||||
((env-after (hk-match-args pats args env)))
|
||||
(cond
|
||||
((nil? env-after)
|
||||
(hk-dispatch-multi (rest clauses) args env))
|
||||
(:else (hk-eval body env-after))))))))))
|
||||
|
||||
(define
|
||||
hk-match-args
|
||||
(fn
|
||||
(pats args env)
|
||||
(cond
|
||||
((empty? pats) env)
|
||||
(:else
|
||||
(let
|
||||
((res (hk-match (first pats) (first args) env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else
|
||||
(hk-match-args (rest pats) (rest args) res))))))))
|
||||
|
||||
(define
|
||||
hk-apply-con-partial
|
||||
(fn
|
||||
(cp arg)
|
||||
(let
|
||||
((name (get cp "name"))
|
||||
(arity (get cp "arity"))
|
||||
(args (append (get cp "args") (list arg))))
|
||||
(cond
|
||||
((= (len args) arity) (hk-mk-con name args))
|
||||
(:else (assoc cp "args" args))))))
|
||||
|
||||
(define
|
||||
hk-apply-builtin
|
||||
(fn
|
||||
(b arg)
|
||||
(let
|
||||
((arity (get b "arity"))
|
||||
(collected (append (get b "collected") (list arg))))
|
||||
(cond
|
||||
((< (len collected) arity)
|
||||
(assoc b "collected" collected))
|
||||
(:else
|
||||
;; Strict built-ins force every collected arg before
|
||||
;; calling. Lazy ones (`seq`, `deepseq`) receive the raw
|
||||
;; thunks so they can choose what to force.
|
||||
(cond
|
||||
((get b "lazy") (apply (get b "fn") collected))
|
||||
(:else
|
||||
(apply
|
||||
(get b "fn")
|
||||
(map hk-force collected)))))))))
|
||||
|
||||
;; ── Bool helpers (Bool values are tagged conses) ────────────
|
||||
(define
|
||||
hk-truthy?
|
||||
(fn
|
||||
(v)
|
||||
(and (list? v) (not (empty? v)) (= (first v) "True"))))
|
||||
|
||||
(define hk-true (hk-mk-con "True" (list)))
|
||||
(define hk-false (hk-mk-con "False" (list)))
|
||||
(define hk-of-bool (fn (b) (if b hk-true hk-false)))
|
||||
|
||||
;; ── Core eval ───────────────────────────────────────────────
|
||||
(define
|
||||
hk-eval
|
||||
(fn
|
||||
(node env)
|
||||
(cond
|
||||
((not (list? node)) (raise (str "eval: not a list: " node)))
|
||||
((empty? node) (raise "eval: empty list node"))
|
||||
(:else
|
||||
(let
|
||||
((tag (first node)))
|
||||
(cond
|
||||
((= tag "int") (nth node 1))
|
||||
((= tag "float") (nth node 1))
|
||||
((= tag "string") (nth node 1))
|
||||
((= tag "char") (nth node 1))
|
||||
((= tag "var") (hk-eval-var (nth node 1) env))
|
||||
((= tag "con") (hk-eval-con-ref (nth node 1)))
|
||||
((= tag "neg")
|
||||
(- 0 (hk-force (hk-eval (nth node 1) env))))
|
||||
((= tag "if") (hk-eval-if node env))
|
||||
((= tag "let") (hk-eval-let (nth node 1) (nth node 2) env))
|
||||
((= tag "lambda")
|
||||
(hk-mk-closure (nth node 1) (nth node 2) env))
|
||||
((= tag "app")
|
||||
(hk-apply
|
||||
(hk-eval (nth node 1) env)
|
||||
(hk-mk-thunk (nth node 2) env)))
|
||||
((= tag "op")
|
||||
(hk-eval-op
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(nth node 3)
|
||||
env))
|
||||
((= tag "case")
|
||||
(hk-eval-case (nth node 1) (nth node 2) env))
|
||||
((= tag "tuple")
|
||||
(hk-mk-tuple
|
||||
(map (fn (e) (hk-eval e env)) (nth node 1))))
|
||||
((= tag "list")
|
||||
(hk-mk-list
|
||||
(map (fn (e) (hk-eval e env)) (nth node 1))))
|
||||
((= tag "range")
|
||||
(let
|
||||
((from (hk-force (hk-eval (nth node 1) env)))
|
||||
(to (hk-force (hk-eval (nth node 2) env))))
|
||||
(hk-build-range from to 1)))
|
||||
((= tag "range-step")
|
||||
(let
|
||||
((from (hk-force (hk-eval (nth node 1) env)))
|
||||
(nxt (hk-force (hk-eval (nth node 2) env)))
|
||||
(to (hk-force (hk-eval (nth node 3) env))))
|
||||
(hk-build-range from to (- nxt from))))
|
||||
((= tag "range-from")
|
||||
;; [from..] = iterate (+ 1) from — uses the Prelude.
|
||||
(hk-eval
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "iterate")
|
||||
(list
|
||||
:sect-right
|
||||
"+"
|
||||
(list :int 1)))
|
||||
(nth node 1))
|
||||
env))
|
||||
((= tag "sect-left")
|
||||
(hk-eval-sect-left (nth node 1) (nth node 2) env))
|
||||
((= tag "sect-right")
|
||||
(hk-eval-sect-right (nth node 1) (nth node 2) env))
|
||||
(:else
|
||||
(raise (str "eval: unknown node tag '" tag "'")))))))))
|
||||
|
||||
(define
|
||||
hk-eval-var
|
||||
(fn
|
||||
(name env)
|
||||
(cond
|
||||
((has-key? env name) (get env name))
|
||||
((hk-is-con? name) (hk-eval-con-ref name))
|
||||
(:else (raise (str "unbound variable: " name))))))
|
||||
|
||||
(define
|
||||
hk-eval-con-ref
|
||||
(fn
|
||||
(name)
|
||||
(let ((arity (hk-con-arity name)))
|
||||
(cond
|
||||
((nil? arity) (raise (str "unknown constructor: " name)))
|
||||
((= arity 0) (hk-mk-con name (list)))
|
||||
(:else
|
||||
{:type "con-partial" :name name :arity arity :args (list)})))))
|
||||
|
||||
(define
|
||||
hk-eval-if
|
||||
(fn
|
||||
(node env)
|
||||
(let ((cv (hk-force (hk-eval (nth node 1) env))))
|
||||
(cond
|
||||
((hk-truthy? cv) (hk-eval (nth node 2) env))
|
||||
((and (list? cv) (= (first cv) "False"))
|
||||
(hk-eval (nth node 3) env))
|
||||
((= cv true) (hk-eval (nth node 2) env))
|
||||
((= cv false) (hk-eval (nth node 3) env))
|
||||
(:else (raise "if: condition is not Bool"))))))
|
||||
|
||||
(define
|
||||
hk-extend-env-with-match!
|
||||
(fn
|
||||
(env match-env)
|
||||
(for-each
|
||||
(fn (k) (dict-set! env k (get match-env k)))
|
||||
(keys match-env))))
|
||||
|
||||
(define
|
||||
hk-eval-let-bind!
|
||||
(fn
|
||||
(b env)
|
||||
(let ((tag (first b)))
|
||||
(cond
|
||||
((= tag "fun-clause")
|
||||
(let
|
||||
((name (nth b 1))
|
||||
(pats (nth b 2))
|
||||
(body (nth b 3)))
|
||||
(cond
|
||||
((empty? pats)
|
||||
(dict-set! env name (hk-eval body env)))
|
||||
(:else
|
||||
(dict-set! env name (hk-mk-closure pats body env))))))
|
||||
((or (= tag "bind") (= tag "pat-bind"))
|
||||
(let ((pat (nth b 1)) (body (nth b 2)))
|
||||
(let ((val (hk-eval body env)))
|
||||
(let ((res (hk-match pat val env)))
|
||||
(cond
|
||||
((nil? res)
|
||||
(raise "let: pattern bind failure"))
|
||||
(:else
|
||||
(hk-extend-env-with-match! env res)))))))
|
||||
(:else nil)))))
|
||||
|
||||
(define
|
||||
hk-eval-let
|
||||
(fn
|
||||
(binds body env)
|
||||
(let ((new-env (hk-dict-copy env)))
|
||||
;; Pre-seed names for fn-clauses so closures see themselves
|
||||
;; (mutual recursion across the whole binding group).
|
||||
(for-each
|
||||
(fn (b)
|
||||
(cond
|
||||
((= (first b) "fun-clause")
|
||||
(dict-set! new-env (nth b 1) nil))
|
||||
((and
|
||||
(= (first b) "bind")
|
||||
(list? (nth b 1))
|
||||
(= (first (nth b 1)) "p-var"))
|
||||
(dict-set! new-env (nth (nth b 1) 1) nil))
|
||||
(:else nil)))
|
||||
binds)
|
||||
(for-each (fn (b) (hk-eval-let-bind! b new-env)) binds)
|
||||
(hk-eval body new-env))))
|
||||
|
||||
(define
|
||||
hk-eval-case
|
||||
(fn
|
||||
(scrut alts env)
|
||||
(let ((sv (hk-force (hk-eval scrut env))))
|
||||
(hk-try-alts alts sv env))))
|
||||
|
||||
(define
|
||||
hk-try-alts
|
||||
(fn
|
||||
(alts val env)
|
||||
(cond
|
||||
((empty? alts) (raise "case: non-exhaustive patterns"))
|
||||
(:else
|
||||
(let
|
||||
((alt (first alts)))
|
||||
(let
|
||||
((pat (nth alt 1)) (body (nth alt 2)))
|
||||
(let
|
||||
((res (hk-match pat val env)))
|
||||
(cond
|
||||
((nil? res) (hk-try-alts (rest alts) val env))
|
||||
(:else (hk-eval body res))))))))))
|
||||
|
||||
(define
|
||||
hk-eval-op
|
||||
(fn
|
||||
(op left right env)
|
||||
(cond
|
||||
;; Cons is non-strict in both args: build a cons cell whose
|
||||
;; head and tail are deferred. This is what makes `repeat x =
|
||||
;; x : repeat x` and `fibs = 0 : 1 : zipWith (+) fibs (tail
|
||||
;; fibs)` terminate.
|
||||
((= op ":")
|
||||
(hk-mk-cons
|
||||
(hk-mk-thunk left env)
|
||||
(hk-mk-thunk right env)))
|
||||
(:else
|
||||
(let
|
||||
((lv (hk-force (hk-eval left env)))
|
||||
(rv (hk-force (hk-eval right env))))
|
||||
(hk-binop op lv rv))))))
|
||||
|
||||
(define
|
||||
hk-list-append
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (= (first a) "[]")) b)
|
||||
((and (list? a) (= (first a) ":"))
|
||||
(hk-mk-cons (nth a 1) (hk-list-append (nth a 2) b)))
|
||||
(:else (raise "++: not a list")))))
|
||||
|
||||
;; Eager finite-range spine — handles [from..to] and [from,next..to].
|
||||
;; Step direction is governed by the sign of `step`; when step > 0 we
|
||||
;; stop at to; when step < 0 we stop at to going down.
|
||||
(define
|
||||
hk-build-range
|
||||
(fn
|
||||
(from to step)
|
||||
(cond
|
||||
((and (> step 0) (> from to)) (hk-mk-nil))
|
||||
((and (< step 0) (< from to)) (hk-mk-nil))
|
||||
((= step 0) (hk-mk-nil))
|
||||
(:else
|
||||
(hk-mk-cons from (hk-build-range (+ from step) to step))))))
|
||||
|
||||
(define
|
||||
hk-binop
|
||||
(fn
|
||||
(op lv rv)
|
||||
(cond
|
||||
((= op "+") (+ lv rv))
|
||||
((= op "-") (- lv rv))
|
||||
((= op "*") (* lv rv))
|
||||
((= op "/") (/ lv rv))
|
||||
((= op "==") (hk-of-bool (= lv rv)))
|
||||
((= op "/=") (hk-of-bool (not (= lv rv))))
|
||||
((= op "<") (hk-of-bool (< lv rv)))
|
||||
((= op "<=") (hk-of-bool (<= lv rv)))
|
||||
((= op ">") (hk-of-bool (> lv rv)))
|
||||
((= op ">=") (hk-of-bool (>= lv rv)))
|
||||
((= op "&&") (hk-of-bool (and (hk-truthy? lv) (hk-truthy? rv))))
|
||||
((= op "||") (hk-of-bool (or (hk-truthy? lv) (hk-truthy? rv))))
|
||||
((= op ":") (hk-mk-cons lv rv))
|
||||
((= op "++") (hk-list-append lv rv))
|
||||
(:else (raise (str "unknown operator: " op))))))
|
||||
|
||||
(define
|
||||
hk-eval-sect-left
|
||||
(fn
|
||||
(op e env)
|
||||
;; (e op) = \x -> e op x — bind e once, defer the operator call.
|
||||
(let ((ev (hk-eval e env)))
|
||||
(let ((cenv (hk-dict-copy env)))
|
||||
(dict-set! cenv "__hk-sect-l" ev)
|
||||
(hk-mk-closure
|
||||
(list (list :p-var "__hk-sect-x"))
|
||||
(list
|
||||
:op
|
||||
op
|
||||
(list :var "__hk-sect-l")
|
||||
(list :var "__hk-sect-x"))
|
||||
cenv)))))
|
||||
|
||||
(define
|
||||
hk-eval-sect-right
|
||||
(fn
|
||||
(op e env)
|
||||
(let ((ev (hk-eval e env)))
|
||||
(let ((cenv (hk-dict-copy env)))
|
||||
(dict-set! cenv "__hk-sect-r" ev)
|
||||
(hk-mk-closure
|
||||
(list (list :p-var "__hk-sect-x"))
|
||||
(list
|
||||
:op
|
||||
op
|
||||
(list :var "__hk-sect-x")
|
||||
(list :var "__hk-sect-r"))
|
||||
cenv)))))
|
||||
|
||||
;; ── Top-level program evaluation ────────────────────────────
|
||||
;; Operator-as-value built-ins — let `(+)`, `(*)`, etc. work as
|
||||
;; first-class functions for `zipWith (+)` and friends. Strict in
|
||||
;; both args (built-ins are forced via hk-apply-builtin).
|
||||
(define
|
||||
hk-make-binop-builtin
|
||||
(fn
|
||||
(name op-name)
|
||||
(hk-mk-builtin
|
||||
name
|
||||
(fn (a b) (hk-binop op-name a b))
|
||||
2)))
|
||||
|
||||
;; Inline Prelude source — loaded into the initial env so simple
|
||||
;; programs can use `head`, `take`, `repeat`, etc. without each
|
||||
;; user file redefining them. The Prelude itself uses lazy `:` for
|
||||
;; the recursive list-building functions.
|
||||
(define
|
||||
hk-prelude-src
|
||||
"head (x:_) = x
|
||||
tail (_:xs) = xs
|
||||
fst (a, _) = a
|
||||
snd (_, b) = b
|
||||
take 0 _ = []
|
||||
take _ [] = []
|
||||
take n (x:xs) = x : take (n - 1) xs
|
||||
drop 0 xs = xs
|
||||
drop _ [] = []
|
||||
drop n (_:xs) = drop (n - 1) xs
|
||||
repeat x = x : repeat x
|
||||
iterate f x = x : iterate f (f x)
|
||||
length [] = 0
|
||||
length (_:xs) = 1 + length xs
|
||||
map _ [] = []
|
||||
map f (x:xs) = f x : map f xs
|
||||
filter _ [] = []
|
||||
filter p (x:xs) = if p x then x : filter p xs else filter p xs
|
||||
zipWith _ [] _ = []
|
||||
zipWith _ _ [] = []
|
||||
zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
|
||||
fibs = 0 : 1 : zipWith plus fibs (tail fibs)
|
||||
plus a b = a + b
|
||||
")
|
||||
|
||||
(define
|
||||
hk-load-into!
|
||||
(fn
|
||||
(env src)
|
||||
(let ((ast (hk-core src)))
|
||||
(hk-register-program! ast)
|
||||
(let
|
||||
((decls
|
||||
(cond
|
||||
((= (first ast) "program") (nth ast 1))
|
||||
((= (first ast) "module") (nth ast 4))
|
||||
(:else (list)))))
|
||||
(hk-bind-decls! env decls)))))
|
||||
|
||||
(define
|
||||
hk-init-env
|
||||
(fn
|
||||
()
|
||||
(let ((env (dict)))
|
||||
(dict-set! env "otherwise" hk-true)
|
||||
(dict-set!
|
||||
env
|
||||
"error"
|
||||
(hk-mk-builtin
|
||||
"error"
|
||||
(fn (msg) (raise (str "*** Exception: " msg)))
|
||||
1))
|
||||
(dict-set!
|
||||
env
|
||||
"not"
|
||||
(hk-mk-builtin
|
||||
"not"
|
||||
(fn (b) (hk-of-bool (not (hk-truthy? b))))
|
||||
1))
|
||||
(dict-set!
|
||||
env
|
||||
"id"
|
||||
(hk-mk-builtin "id" (fn (x) x) 1))
|
||||
;; `seq a b` — strict in `a`, lazy in `b`. Forces `a` to WHNF
|
||||
;; and returns `b` unchanged (still a thunk if it was one).
|
||||
(dict-set!
|
||||
env
|
||||
"seq"
|
||||
(hk-mk-lazy-builtin
|
||||
"seq"
|
||||
(fn (a b) (do (hk-force a) b))
|
||||
2))
|
||||
;; `deepseq a b` — like seq but forces `a` to normal form.
|
||||
(dict-set!
|
||||
env
|
||||
"deepseq"
|
||||
(hk-mk-lazy-builtin
|
||||
"deepseq"
|
||||
(fn (a b) (do (hk-deep-force a) b))
|
||||
2))
|
||||
;; ── Stub IO monad ─────────────────────────────────────
|
||||
;; IO actions are tagged values `("IO" payload)`; `>>=` and
|
||||
;; `>>` chain them. Lazy in the action arguments so do-blocks
|
||||
;; can be deeply structured without forcing the whole chain
|
||||
;; up front.
|
||||
(dict-set!
|
||||
env
|
||||
"return"
|
||||
(hk-mk-lazy-builtin
|
||||
"return"
|
||||
(fn (x) (list "IO" x))
|
||||
1))
|
||||
(dict-set!
|
||||
env
|
||||
">>="
|
||||
(hk-mk-lazy-builtin
|
||||
">>="
|
||||
(fn (m f)
|
||||
(let ((io-val (hk-force m)))
|
||||
(cond
|
||||
((and
|
||||
(list? io-val)
|
||||
(= (first io-val) "IO"))
|
||||
(hk-apply (hk-force f) (nth io-val 1)))
|
||||
(:else
|
||||
(raise "(>>=): left side is not an IO action")))))
|
||||
2))
|
||||
(dict-set!
|
||||
env
|
||||
">>"
|
||||
(hk-mk-lazy-builtin
|
||||
">>"
|
||||
(fn (m n)
|
||||
(let ((io-val (hk-force m)))
|
||||
(cond
|
||||
((and
|
||||
(list? io-val)
|
||||
(= (first io-val) "IO"))
|
||||
(hk-force n))
|
||||
(:else
|
||||
(raise "(>>): left side is not an IO action")))))
|
||||
2))
|
||||
;; Operators as first-class values
|
||||
(dict-set! env "+" (hk-make-binop-builtin "+" "+"))
|
||||
(dict-set! env "-" (hk-make-binop-builtin "-" "-"))
|
||||
(dict-set! env "*" (hk-make-binop-builtin "*" "*"))
|
||||
(dict-set! env "/" (hk-make-binop-builtin "/" "/"))
|
||||
(dict-set! env "==" (hk-make-binop-builtin "==" "=="))
|
||||
(dict-set! env "/=" (hk-make-binop-builtin "/=" "/="))
|
||||
(dict-set! env "<" (hk-make-binop-builtin "<" "<"))
|
||||
(dict-set! env "<=" (hk-make-binop-builtin "<=" "<="))
|
||||
(dict-set! env ">" (hk-make-binop-builtin ">" ">"))
|
||||
(dict-set! env ">=" (hk-make-binop-builtin ">=" ">="))
|
||||
(dict-set! env "&&" (hk-make-binop-builtin "&&" "&&"))
|
||||
(dict-set! env "||" (hk-make-binop-builtin "||" "||"))
|
||||
(dict-set! env "++" (hk-make-binop-builtin "++" "++"))
|
||||
(hk-load-into! env hk-prelude-src)
|
||||
env)))
|
||||
|
||||
(define
|
||||
hk-bind-decls!
|
||||
(fn
|
||||
(env decls)
|
||||
(let ((groups (dict)) (pat-binds (list)))
|
||||
;; Pass 1: collect fun-clause groups by name; collect pat-binds
|
||||
;; in source order. Pre-seed env so any name can already be
|
||||
;; looked up by closures built in pass 2.
|
||||
(for-each
|
||||
(fn (d)
|
||||
(cond
|
||||
((= (first d) "fun-clause")
|
||||
(let
|
||||
((name (nth d 1)))
|
||||
(dict-set!
|
||||
groups
|
||||
name
|
||||
(append
|
||||
(if
|
||||
(has-key? groups name)
|
||||
(get groups name)
|
||||
(list))
|
||||
(list (list (nth d 2) (nth d 3)))))
|
||||
(when
|
||||
(not (has-key? env name))
|
||||
(dict-set! env name nil))))
|
||||
((or (= (first d) "bind") (= (first d) "pat-bind"))
|
||||
(append! pat-binds d))
|
||||
(:else nil)))
|
||||
decls)
|
||||
;; Pass 2: install multifuns for arity > 0; mark 0-arity for
|
||||
;; pass 3. The mutable env means recursive references work.
|
||||
(let ((zero-arity (list)))
|
||||
(for-each
|
||||
(fn (name)
|
||||
(let ((clauses (get groups name)))
|
||||
(let ((arity (len (first (first clauses)))))
|
||||
(cond
|
||||
((> arity 0)
|
||||
(dict-set!
|
||||
env
|
||||
name
|
||||
(hk-mk-multifun arity clauses env)))
|
||||
(:else (append! zero-arity name))))))
|
||||
(keys groups))
|
||||
;; Pass 3: evaluate 0-arity bodies and pat-binds.
|
||||
(for-each
|
||||
(fn (name)
|
||||
(let ((clauses (get groups name)))
|
||||
(dict-set!
|
||||
env
|
||||
name
|
||||
(hk-eval (first (rest (first clauses))) env))))
|
||||
zero-arity)
|
||||
(for-each
|
||||
(fn (d)
|
||||
(let ((pat (nth d 1)) (body (nth d 2)))
|
||||
(let ((val (hk-eval body env)))
|
||||
(let ((res (hk-match pat val env)))
|
||||
(cond
|
||||
((nil? res)
|
||||
(raise "top-level pattern bind failure"))
|
||||
(:else (hk-extend-env-with-match! env res)))))))
|
||||
pat-binds))
|
||||
env)))
|
||||
|
||||
(define
|
||||
hk-eval-program
|
||||
(fn
|
||||
(ast)
|
||||
(cond
|
||||
((nil? ast) (raise "eval-program: nil ast"))
|
||||
((not (list? ast)) (raise "eval-program: not a list"))
|
||||
(:else
|
||||
(do
|
||||
(hk-register-program! ast)
|
||||
(let ((env (hk-init-env)))
|
||||
(let
|
||||
((decls
|
||||
(cond
|
||||
((= (first ast) "program") (nth ast 1))
|
||||
((= (first ast) "module") (nth ast 4))
|
||||
(:else (raise "eval-program: bad shape")))))
|
||||
(hk-bind-decls! env decls))))))))
|
||||
|
||||
;; ── Source-level convenience ────────────────────────────────
|
||||
(define
|
||||
hk-run
|
||||
(fn
|
||||
(src)
|
||||
(let ((env (hk-eval-program (hk-core src))))
|
||||
(cond
|
||||
((has-key? env "main") (get env "main"))
|
||||
(:else env)))))
|
||||
|
||||
(define
|
||||
hk-eval-expr-source
|
||||
(fn
|
||||
(src)
|
||||
(hk-deep-force (hk-eval (hk-core-expr src) (hk-init-env)))))
|
||||
@@ -1,329 +0,0 @@
|
||||
;; Haskell 98 layout algorithm (§10.3).
|
||||
;;
|
||||
;; Consumes the raw token stream produced by hk-tokenize and inserts
|
||||
;; virtual braces / semicolons (types vlbrace / vrbrace / vsemi) based
|
||||
;; on indentation. Newline tokens are consumed and stripped.
|
||||
;;
|
||||
;; (hk-layout (hk-tokenize src)) → tokens-with-virtual-layout
|
||||
|
||||
;; ── Pre-pass ──────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Walks the raw token list and emits an augmented stream containing
|
||||
;; two fresh pseudo-tokens:
|
||||
;;
|
||||
;; {:type "layout-open" :col N :keyword K}
|
||||
;; At stream start (K = "<module>") unless the first real token is
|
||||
;; `module` or `{`. Also immediately after every `let` / `where` /
|
||||
;; `do` / `of` whose following token is NOT `{`. N is the column
|
||||
;; of the token that follows.
|
||||
;;
|
||||
;; {:type "layout-indent" :col N}
|
||||
;; Before any token whose line is strictly greater than the line
|
||||
;; of the previously emitted real token, EXCEPT when that token
|
||||
;; is already preceded by a layout-open (Haskell 98 §10.3 note 3).
|
||||
;;
|
||||
;; Raw newline tokens are dropped.
|
||||
|
||||
(define
|
||||
hk-layout-keyword?
|
||||
(fn
|
||||
(tok)
|
||||
(and
|
||||
(= (get tok "type") "reserved")
|
||||
(or
|
||||
(= (get tok "value") "let")
|
||||
(= (get tok "value") "where")
|
||||
(= (get tok "value") "do")
|
||||
(= (get tok "value") "of")))))
|
||||
|
||||
(define
|
||||
hk-layout-pre
|
||||
(fn
|
||||
(tokens)
|
||||
(let
|
||||
((result (list))
|
||||
(n (len tokens))
|
||||
(i 0)
|
||||
(prev-line -1)
|
||||
(first-real-emitted false)
|
||||
(suppress-next-indent false))
|
||||
(define
|
||||
hk-next-real-idx
|
||||
(fn
|
||||
(start)
|
||||
(let
|
||||
((j start))
|
||||
(define
|
||||
hk-nri-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< j n)
|
||||
(= (get (nth tokens j) "type") "newline"))
|
||||
(do (set! j (+ j 1)) (hk-nri-loop)))))
|
||||
(hk-nri-loop)
|
||||
j)))
|
||||
(define
|
||||
hk-pre-step
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((tok (nth tokens i)) (ty (get tok "type")))
|
||||
(cond
|
||||
((= ty "newline") (do (set! i (+ i 1)) (hk-pre-step)))
|
||||
(:else
|
||||
(do
|
||||
(when
|
||||
(not first-real-emitted)
|
||||
(do
|
||||
(set! first-real-emitted true)
|
||||
(when
|
||||
(not
|
||||
(or
|
||||
(and
|
||||
(= ty "reserved")
|
||||
(= (get tok "value") "module"))
|
||||
(= ty "lbrace")))
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col (get tok "col")
|
||||
:keyword "<module>"
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true)))))
|
||||
(when
|
||||
(and
|
||||
(>= prev-line 0)
|
||||
(> (get tok "line") prev-line)
|
||||
(not suppress-next-indent))
|
||||
(append!
|
||||
result
|
||||
{:type "layout-indent"
|
||||
:col (get tok "col")
|
||||
:line (get tok "line")}))
|
||||
(set! suppress-next-indent false)
|
||||
(set! prev-line (get tok "line"))
|
||||
(append! result tok)
|
||||
(when
|
||||
(hk-layout-keyword? tok)
|
||||
(let
|
||||
((j (hk-next-real-idx (+ i 1))))
|
||||
(cond
|
||||
((>= j n)
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col 0
|
||||
:keyword (get tok "value")
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true)))
|
||||
((= (get (nth tokens j) "type") "lbrace") nil)
|
||||
(:else
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col (get (nth tokens j) "col")
|
||||
:keyword (get tok "value")
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true))))))
|
||||
(set! i (+ i 1))
|
||||
(hk-pre-step))))))))
|
||||
(hk-pre-step)
|
||||
result)))
|
||||
|
||||
;; ── Main pass: L algorithm ────────────────────────────────────────
|
||||
;;
|
||||
;; Stack is a list; the head is the top of stack. Each entry is
|
||||
;; either the keyword :explicit (pushed by an explicit `{`) or a dict
|
||||
;; {:col N :keyword K} pushed by a layout-open marker.
|
||||
;;
|
||||
;; Rules (following Haskell 98 §10.3):
|
||||
;;
|
||||
;; layout-open(n) vs stack:
|
||||
;; empty or explicit top → push n; emit {
|
||||
;; n > top-col → push n; emit {
|
||||
;; otherwise → emit { }; retry as indent(n)
|
||||
;;
|
||||
;; layout-indent(n) vs stack:
|
||||
;; empty or explicit top → drop
|
||||
;; n == top-col → emit ;
|
||||
;; n < top-col → emit }; pop; recurse
|
||||
;; n > top-col → drop
|
||||
;;
|
||||
;; lbrace → push :explicit; emit {
|
||||
;; rbrace → pop if :explicit; emit }
|
||||
;; `in` with implicit let on top → emit }; pop; emit in
|
||||
;; any other token → emit
|
||||
;;
|
||||
;; EOF: emit } for every remaining implicit context.
|
||||
|
||||
(define
|
||||
hk-layout-L
|
||||
(fn
|
||||
(pre-toks)
|
||||
(let
|
||||
((result (list))
|
||||
(stack (list))
|
||||
(n (len pre-toks))
|
||||
(i 0))
|
||||
(define hk-emit (fn (t) (append! result t)))
|
||||
(define
|
||||
hk-indent-at
|
||||
(fn
|
||||
(col line)
|
||||
(cond
|
||||
((or (empty? stack) (= (first stack) :explicit)) nil)
|
||||
(:else
|
||||
(let
|
||||
((top-col (get (first stack) "col")))
|
||||
(cond
|
||||
((= col top-col)
|
||||
(hk-emit
|
||||
{:type "vsemi" :value ";" :line line :col col}))
|
||||
((< col top-col)
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vrbrace" :value "}" :line line :col col})
|
||||
(set! stack (rest stack))
|
||||
(hk-indent-at col line)))
|
||||
(:else nil)))))))
|
||||
(define
|
||||
hk-open-at
|
||||
(fn
|
||||
(col keyword line)
|
||||
(cond
|
||||
((and
|
||||
(> col 0)
|
||||
(or
|
||||
(empty? stack)
|
||||
(= (first stack) :explicit)
|
||||
(> col (get (first stack) "col"))))
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vlbrace" :value "{" :line line :col col})
|
||||
(set! stack (cons {:col col :keyword keyword} stack))))
|
||||
(:else
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vlbrace" :value "{" :line line :col col})
|
||||
(hk-emit
|
||||
{:type "vrbrace" :value "}" :line line :col col})
|
||||
(hk-indent-at col line))))))
|
||||
(define
|
||||
hk-close-eof
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(not (empty? stack))
|
||||
(not (= (first stack) :explicit)))
|
||||
(do
|
||||
(hk-emit {:type "vrbrace" :value "}" :line 0 :col 0})
|
||||
(set! stack (rest stack))
|
||||
(hk-close-eof)))))
|
||||
;; Peek past further layout-indent / layout-open markers to find
|
||||
;; the next real token's value when its type is `reserved`.
|
||||
;; Returns nil if no such token.
|
||||
(define
|
||||
hk-peek-next-reserved
|
||||
(fn
|
||||
(start)
|
||||
(let ((j (+ start 1)) (found nil) (done false))
|
||||
(define
|
||||
hk-pnr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not done) (< j n))
|
||||
(let
|
||||
((t (nth pre-toks j)) (ty (get t "type")))
|
||||
(cond
|
||||
((or
|
||||
(= ty "layout-indent")
|
||||
(= ty "layout-open"))
|
||||
(do (set! j (+ j 1)) (hk-pnr-loop)))
|
||||
((= ty "reserved")
|
||||
(do (set! found (get t "value")) (set! done true)))
|
||||
(:else (set! done true)))))))
|
||||
(hk-pnr-loop)
|
||||
found)))
|
||||
(define
|
||||
hk-layout-step
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((tok (nth pre-toks i)) (ty (get tok "type")))
|
||||
(cond
|
||||
((= ty "eof")
|
||||
(do
|
||||
(hk-close-eof)
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "layout-open")
|
||||
(do
|
||||
(hk-open-at
|
||||
(get tok "col")
|
||||
(get tok "keyword")
|
||||
(get tok "line"))
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "layout-indent")
|
||||
(cond
|
||||
((= (hk-peek-next-reserved i) "in")
|
||||
(do (set! i (+ i 1)) (hk-layout-step)))
|
||||
(:else
|
||||
(do
|
||||
(hk-indent-at (get tok "col") (get tok "line"))
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))))
|
||||
((= ty "lbrace")
|
||||
(do
|
||||
(set! stack (cons :explicit stack))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "rbrace")
|
||||
(do
|
||||
(when
|
||||
(and
|
||||
(not (empty? stack))
|
||||
(= (first stack) :explicit))
|
||||
(set! stack (rest stack)))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((and
|
||||
(= ty "reserved")
|
||||
(= (get tok "value") "in")
|
||||
(not (empty? stack))
|
||||
(not (= (first stack) :explicit))
|
||||
(= (get (first stack) "keyword") "let"))
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vrbrace"
|
||||
:value "}"
|
||||
:line (get tok "line")
|
||||
:col (get tok "col")})
|
||||
(set! stack (rest stack))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
(:else
|
||||
(do
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step))))))))
|
||||
(hk-layout-step)
|
||||
(hk-close-eof)
|
||||
result)))
|
||||
|
||||
(define hk-layout (fn (tokens) (hk-layout-L (hk-layout-pre tokens))))
|
||||
@@ -1,201 +0,0 @@
|
||||
;; Value-level pattern matching.
|
||||
;;
|
||||
;; Constructor values are tagged lists whose first element is the
|
||||
;; constructor name (a string). Tuples use the special tag "Tuple".
|
||||
;; Lists use the spine of `:` cons and `[]` nil.
|
||||
;;
|
||||
;; Just 5 → ("Just" 5)
|
||||
;; Nothing → ("Nothing")
|
||||
;; (1, 2) → ("Tuple" 1 2)
|
||||
;; [1, 2] → (":" 1 (":" 2 ("[]")))
|
||||
;; () → ("()")
|
||||
;;
|
||||
;; Primitive values (numbers, strings, chars) are stored raw.
|
||||
;;
|
||||
;; The matcher takes a pattern AST node, a value, and an environment
|
||||
;; dict; it returns an extended dict on success, or `nil` on failure.
|
||||
|
||||
;; ── Value builders ──────────────────────────────────────────
|
||||
(define
|
||||
hk-mk-con
|
||||
(fn
|
||||
(cname args)
|
||||
(let ((result (list cname)))
|
||||
(for-each (fn (a) (append! result a)) args)
|
||||
result)))
|
||||
|
||||
(define
|
||||
hk-mk-tuple
|
||||
(fn
|
||||
(items)
|
||||
(let ((result (list "Tuple")))
|
||||
(for-each (fn (x) (append! result x)) items)
|
||||
result)))
|
||||
|
||||
(define hk-mk-nil (fn () (list "[]")))
|
||||
|
||||
(define hk-mk-cons (fn (h t) (list ":" h t)))
|
||||
|
||||
(define
|
||||
hk-mk-list
|
||||
(fn
|
||||
(items)
|
||||
(cond
|
||||
((empty? items) (hk-mk-nil))
|
||||
(:else
|
||||
(hk-mk-cons (first items) (hk-mk-list (rest items)))))))
|
||||
|
||||
;; ── Predicates / accessors on constructor values ───────────
|
||||
(define
|
||||
hk-is-con-val?
|
||||
(fn
|
||||
(v)
|
||||
(and
|
||||
(list? v)
|
||||
(not (empty? v))
|
||||
(string? (first v)))))
|
||||
|
||||
(define hk-val-con-name (fn (v) (first v)))
|
||||
|
||||
(define hk-val-con-args (fn (v) (rest v)))
|
||||
|
||||
;; ── The matcher ────────────────────────────────────────────
|
||||
;;
|
||||
;; Pattern match forces the scrutinee to WHNF before inspecting it
|
||||
;; — except for `p-wild`, `p-var`, and `p-lazy`, which never need
|
||||
;; to look at the value. Args of constructor / tuple / list values
|
||||
;; remain thunked (they're forced only when their own pattern needs
|
||||
;; to inspect them, recursively).
|
||||
(define
|
||||
hk-match
|
||||
(fn
|
||||
(pat val env)
|
||||
(cond
|
||||
((not (list? pat)) nil)
|
||||
((empty? pat) nil)
|
||||
(:else
|
||||
(let
|
||||
((tag (first pat)))
|
||||
(cond
|
||||
((= tag "p-wild") env)
|
||||
((= tag "p-var") (assoc env (nth pat 1) val))
|
||||
((= tag "p-lazy") (hk-match (nth pat 1) val env))
|
||||
((= tag "p-as")
|
||||
(let
|
||||
((res (hk-match (nth pat 2) val env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else (assoc res (nth pat 1) val)))))
|
||||
(:else
|
||||
(let ((fv (hk-force val)))
|
||||
(cond
|
||||
((= tag "p-int")
|
||||
(if
|
||||
(and (number? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-float")
|
||||
(if
|
||||
(and (number? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-string")
|
||||
(if
|
||||
(and (string? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-char")
|
||||
(if
|
||||
(and (string? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-con")
|
||||
(let
|
||||
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
|
||||
(cond
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) pat-name)) nil)
|
||||
(:else
|
||||
(let
|
||||
((val-args (hk-val-con-args fv)))
|
||||
(cond
|
||||
((not (= (len pat-args) (len val-args)))
|
||||
nil)
|
||||
(:else
|
||||
(hk-match-all
|
||||
pat-args
|
||||
val-args
|
||||
env))))))))
|
||||
((= tag "p-tuple")
|
||||
(let
|
||||
((items (nth pat 1)))
|
||||
(cond
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) "Tuple")) nil)
|
||||
((not (= (len (hk-val-con-args fv)) (len items)))
|
||||
nil)
|
||||
(:else
|
||||
(hk-match-all
|
||||
items
|
||||
(hk-val-con-args fv)
|
||||
env)))))
|
||||
((= tag "p-list")
|
||||
(hk-match-list-pat (nth pat 1) fv env))
|
||||
(:else nil))))))))))
|
||||
|
||||
(define
|
||||
hk-match-all
|
||||
(fn
|
||||
(pats vals env)
|
||||
(cond
|
||||
((empty? pats) env)
|
||||
(:else
|
||||
(let
|
||||
((res (hk-match (first pats) (first vals) env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else
|
||||
(hk-match-all (rest pats) (rest vals) res))))))))
|
||||
|
||||
(define
|
||||
hk-match-list-pat
|
||||
(fn
|
||||
(items val env)
|
||||
(let ((fv (hk-force val)))
|
||||
(cond
|
||||
((empty? items)
|
||||
(if
|
||||
(and
|
||||
(hk-is-con-val? fv)
|
||||
(= (hk-val-con-name fv) "[]"))
|
||||
env
|
||||
nil))
|
||||
(:else
|
||||
(cond
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) ":")) nil)
|
||||
(:else
|
||||
(let
|
||||
((args (hk-val-con-args fv)))
|
||||
(let
|
||||
((h (first args)) (t (first (rest args))))
|
||||
(let
|
||||
((res (hk-match (first items) h env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else
|
||||
(hk-match-list-pat
|
||||
(rest items)
|
||||
t
|
||||
res)))))))))))))
|
||||
|
||||
;; ── Convenience: parse a pattern from source for tests ─────
|
||||
;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
|
||||
;; to extract a pattern AST.)
|
||||
(define
|
||||
hk-parse-pat-source
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((expr (hk-parse (str "case 0 of " src " -> 0"))))
|
||||
(nth (nth (nth expr 2) 0) 1))))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,130 +0,0 @@
|
||||
;; Haskell runtime: constructor registry.
|
||||
;;
|
||||
;; A mutable dict keyed by constructor name (e.g. "Just", "[]") with
|
||||
;; entries of shape {:arity N :type TYPE-NAME-STRING}.
|
||||
;; Populated by ingesting `data` / `newtype` decls from parsed ASTs.
|
||||
;; Pre-registers a small set of constructors tied to Haskell syntactic
|
||||
;; forms (Bool, list, unit) — every nontrivial program depends on
|
||||
;; these, and the parser/desugar pipeline emits them as (:var "True")
|
||||
;; etc. without a corresponding `data` decl.
|
||||
|
||||
(define hk-constructors (dict))
|
||||
|
||||
(define
|
||||
hk-register-con!
|
||||
(fn
|
||||
(cname arity type-name)
|
||||
(dict-set!
|
||||
hk-constructors
|
||||
cname
|
||||
{:arity arity :type type-name})))
|
||||
|
||||
(define hk-is-con? (fn (name) (has-key? hk-constructors name)))
|
||||
|
||||
(define
|
||||
hk-con-arity
|
||||
(fn
|
||||
(name)
|
||||
(if
|
||||
(has-key? hk-constructors name)
|
||||
(get (get hk-constructors name) "arity")
|
||||
nil)))
|
||||
|
||||
(define
|
||||
hk-con-type
|
||||
(fn
|
||||
(name)
|
||||
(if
|
||||
(has-key? hk-constructors name)
|
||||
(get (get hk-constructors name) "type")
|
||||
nil)))
|
||||
|
||||
(define hk-con-names (fn () (keys hk-constructors)))
|
||||
|
||||
;; ── Registration from AST ────────────────────────────────────
|
||||
;; (:data NAME TVARS ((:con-def CNAME FIELDS) …))
|
||||
(define
|
||||
hk-register-data!
|
||||
(fn
|
||||
(data-node)
|
||||
(let
|
||||
((type-name (nth data-node 1))
|
||||
(cons-list (nth data-node 3)))
|
||||
(for-each
|
||||
(fn
|
||||
(cd)
|
||||
(hk-register-con!
|
||||
(nth cd 1)
|
||||
(len (nth cd 2))
|
||||
type-name))
|
||||
cons-list))))
|
||||
|
||||
;; (:newtype NAME TVARS CNAME FIELD)
|
||||
(define
|
||||
hk-register-newtype!
|
||||
(fn
|
||||
(nt-node)
|
||||
(hk-register-con!
|
||||
(nth nt-node 3)
|
||||
1
|
||||
(nth nt-node 1))))
|
||||
|
||||
;; Walk a decls list, registering every `data` / `newtype` decl.
|
||||
(define
|
||||
hk-register-decls!
|
||||
(fn
|
||||
(decls)
|
||||
(for-each
|
||||
(fn
|
||||
(d)
|
||||
(cond
|
||||
((and
|
||||
(list? d)
|
||||
(not (empty? d))
|
||||
(= (first d) "data"))
|
||||
(hk-register-data! d))
|
||||
((and
|
||||
(list? d)
|
||||
(not (empty? d))
|
||||
(= (first d) "newtype"))
|
||||
(hk-register-newtype! d))
|
||||
(:else nil)))
|
||||
decls)))
|
||||
|
||||
(define
|
||||
hk-register-program!
|
||||
(fn
|
||||
(ast)
|
||||
(cond
|
||||
((nil? ast) nil)
|
||||
((not (list? ast)) nil)
|
||||
((empty? ast) nil)
|
||||
((= (first ast) "program")
|
||||
(hk-register-decls! (nth ast 1)))
|
||||
((= (first ast) "module")
|
||||
(hk-register-decls! (nth ast 4)))
|
||||
(:else nil))))
|
||||
|
||||
;; Convenience: source → AST → desugar → register.
|
||||
(define
|
||||
hk-load-source!
|
||||
(fn (src) (hk-register-program! (hk-core src))))
|
||||
|
||||
;; ── Built-in constructors pre-registered ─────────────────────
|
||||
;; Bool — used implicitly by `if`, comparison operators.
|
||||
(hk-register-con! "True" 0 "Bool")
|
||||
(hk-register-con! "False" 0 "Bool")
|
||||
;; List — used by list literals, range syntax, and cons operator.
|
||||
(hk-register-con! "[]" 0 "List")
|
||||
(hk-register-con! ":" 2 "List")
|
||||
;; Unit — produced by empty parens `()`.
|
||||
(hk-register-con! "()" 0 "Unit")
|
||||
;; Standard Prelude types — pre-registered so expression-level
|
||||
;; programs can use them without a `data` decl.
|
||||
(hk-register-con! "Nothing" 0 "Maybe")
|
||||
(hk-register-con! "Just" 1 "Maybe")
|
||||
(hk-register-con! "Left" 1 "Either")
|
||||
(hk-register-con! "Right" 1 "Either")
|
||||
(hk-register-con! "LT" 0 "Ordering")
|
||||
(hk-register-con! "EQ" 0 "Ordering")
|
||||
(hk-register-con! "GT" 0 "Ordering")
|
||||
@@ -46,13 +46,6 @@ for FILE in "${FILES[@]}"; do
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/haskell/tokenizer.sx")
|
||||
(load "lib/haskell/layout.sx")
|
||||
(load "lib/haskell/parser.sx")
|
||||
(load "lib/haskell/desugar.sx")
|
||||
(load "lib/haskell/runtime.sx")
|
||||
(load "lib/haskell/match.sx")
|
||||
(load "lib/haskell/eval.sx")
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
@@ -88,13 +81,6 @@ EPOCHS
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/haskell/tokenizer.sx")
|
||||
(load "lib/haskell/layout.sx")
|
||||
(load "lib/haskell/parser.sx")
|
||||
(load "lib/haskell/desugar.sx")
|
||||
(load "lib/haskell/runtime.sx")
|
||||
(load "lib/haskell/match.sx")
|
||||
(load "lib/haskell/eval.sx")
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
|
||||
@@ -1,58 +0,0 @@
|
||||
;; Shared test harness for Haskell-on-SX tests.
|
||||
;; Each test file expects hk-test / hk-deep=? / counters to already be bound.
|
||||
|
||||
(define
|
||||
hk-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn
|
||||
(k)
|
||||
(and (has-key? b k) (hk-deep=? (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
hk-de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (hk-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(hk-de-loop)))))
|
||||
(hk-de-loop)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define hk-test-pass 0)
|
||||
(define hk-test-fail 0)
|
||||
(define hk-test-fails (list))
|
||||
|
||||
(define
|
||||
hk-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(hk-deep=? actual expected)
|
||||
(set! hk-test-pass (+ hk-test-pass 1))
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append!
|
||||
hk-test-fails
|
||||
{:actual actual :expected expected :name name})))))
|
||||
@@ -1,305 +0,0 @@
|
||||
;; Desugar tests — surface AST → core AST.
|
||||
;; :guarded → nested :if
|
||||
;; :where → :let
|
||||
;; :list-comp → concatMap-based tree
|
||||
|
||||
(define
|
||||
hk-prog
|
||||
(fn (&rest decls) (list :program decls)))
|
||||
|
||||
;; ── Guards → if ──
|
||||
(hk-test
|
||||
"two-way guarded rhs"
|
||||
(hk-desugar (hk-parse-top "abs x | x < 0 = - x\n | otherwise = x"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"abs"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op "<" (list :var "x") (list :int 0))
|
||||
(list :neg (list :var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :var "x")
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards")))))))
|
||||
|
||||
(hk-test
|
||||
"three-way guarded rhs"
|
||||
(hk-desugar
|
||||
(hk-parse-top "sign n | n > 0 = 1\n | n < 0 = -1\n | otherwise = 0"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "n") (list :int 0))
|
||||
(list :int 1)
|
||||
(list
|
||||
:if
|
||||
(list :op "<" (list :var "n") (list :int 0))
|
||||
(list :neg (list :int 1))
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards"))))))))
|
||||
|
||||
(hk-test
|
||||
"case-alt guards desugared too"
|
||||
(hk-desugar
|
||||
(hk-parse "case x of\n Just y | y > 0 -> y\n | otherwise -> 0\n Nothing -> -1"))
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "y") (list :int 0))
|
||||
(list :var "y")
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards")))))
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Nothing" (list))
|
||||
(list :neg (list :int 1))))))
|
||||
|
||||
;; ── Where → let ──
|
||||
(hk-test
|
||||
"where with single binding"
|
||||
(hk-desugar (hk-parse-top "f x = y\n where y = x + 1"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1))))
|
||||
(list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"where with two bindings"
|
||||
(hk-desugar
|
||||
(hk-parse-top "f x = y + z\n where y = x + 1\n z = x - 1"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1)))
|
||||
(list
|
||||
:fun-clause
|
||||
"z"
|
||||
(list)
|
||||
(list :op "-" (list :var "x") (list :int 1))))
|
||||
(list :op "+" (list :var "y") (list :var "z"))))))
|
||||
|
||||
(hk-test
|
||||
"guards + where — guarded body inside let"
|
||||
(hk-desugar
|
||||
(hk-parse-top "f x | x > 0 = y\n | otherwise = 0\n where y = 99"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list (list :fun-clause "y" (list) (list :int 99)))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "y")
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards"))))))))
|
||||
|
||||
;; ── List comprehensions → concatMap / if / let ──
|
||||
(hk-test
|
||||
"list-comp: single generator"
|
||||
(hk-core-expr "[x | x <- xs]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list :list (list (list :var "x")))))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"list-comp: generator then guard"
|
||||
(hk-core-expr "[x * 2 | x <- xs, x > 0]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list
|
||||
:list
|
||||
(list (list :op "*" (list :var "x") (list :int 2))))
|
||||
(list :list (list)))))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"list-comp: generator then let"
|
||||
(hk-core-expr "[y | x <- xs, let y = x + 1]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "y")
|
||||
(list :op "+" (list :var "x") (list :int 1))))
|
||||
(list :list (list (list :var "y"))))))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"list-comp: two generators (nested concatMap)"
|
||||
(hk-core-expr "[(x, y) | x <- xs, y <- ys]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "y"))
|
||||
(list
|
||||
:list
|
||||
(list
|
||||
(list
|
||||
:tuple
|
||||
(list (list :var "x") (list :var "y")))))))
|
||||
(list :var "ys"))))
|
||||
(list :var "xs")))
|
||||
|
||||
;; ── Pass-through cases ──
|
||||
(hk-test
|
||||
"plain int literal unchanged"
|
||||
(hk-core-expr "42")
|
||||
(list :int 42))
|
||||
|
||||
(hk-test
|
||||
"lambda + if passes through"
|
||||
(hk-core-expr "\\x -> if x > 0 then x else - x")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "x")
|
||||
(list :neg (list :var "x")))))
|
||||
|
||||
(hk-test
|
||||
"simple fun-clause (no guards/where) passes through"
|
||||
(hk-desugar (hk-parse-top "id x = x"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"id"
|
||||
(list (list :p-var "x"))
|
||||
(list :var "x"))))
|
||||
|
||||
(hk-test
|
||||
"data decl passes through"
|
||||
(hk-desugar (hk-parse-top "data Maybe a = Nothing | Just a"))
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Maybe"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Nothing" (list))
|
||||
(list :con-def "Just" (list (list :t-var "a")))))))
|
||||
|
||||
(hk-test
|
||||
"module header passes through, body desugared"
|
||||
(hk-desugar
|
||||
(hk-parse-top "module M where\nf x | x > 0 = 1\n | otherwise = 0"))
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list)
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :int 1)
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards"))))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,117 +0,0 @@
|
||||
;; do-notation + stub IO monad. Desugaring is per Haskell 98 §3.14:
|
||||
;; do { e ; ss } = e >> do { ss }
|
||||
;; do { p <- e ; ss } = e >>= \p -> do { ss }
|
||||
;; do { let ds ; ss } = let ds in do { ss }
|
||||
;; do { e } = e
|
||||
;; The IO type is just `("IO" payload)` for now — no real side
|
||||
;; effects yet. `return`, `>>=`, `>>` are built-ins.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
;; ── Single-statement do ──
|
||||
(hk-test
|
||||
"do with a single expression"
|
||||
(hk-eval-expr-source "do { return 5 }")
|
||||
(list "IO" 5))
|
||||
|
||||
(hk-test
|
||||
"return wraps any expression"
|
||||
(hk-eval-expr-source "return (1 + 2 * 3)")
|
||||
(list "IO" 7))
|
||||
|
||||
;; ── Bind threads results ──
|
||||
(hk-test
|
||||
"single bind"
|
||||
(hk-eval-expr-source
|
||||
"do { x <- return 5 ; return (x + 1) }")
|
||||
(list "IO" 6))
|
||||
|
||||
(hk-test
|
||||
"two binds"
|
||||
(hk-eval-expr-source
|
||||
"do\n x <- return 5\n y <- return 7\n return (x + y)")
|
||||
(list "IO" 12))
|
||||
|
||||
(hk-test
|
||||
"three binds — accumulating"
|
||||
(hk-eval-expr-source
|
||||
"do\n a <- return 1\n b <- return 2\n c <- return 3\n return (a + b + c)")
|
||||
(list "IO" 6))
|
||||
|
||||
;; ── Mixing >> and >>= ──
|
||||
(hk-test
|
||||
">> sequencing — last wins"
|
||||
(hk-eval-expr-source
|
||||
"do\n return 1\n return 2\n return 3")
|
||||
(list "IO" 3))
|
||||
|
||||
(hk-test
|
||||
">> then >>= — last bind wins"
|
||||
(hk-eval-expr-source
|
||||
"do\n return 99\n x <- return 5\n return x")
|
||||
(list "IO" 5))
|
||||
|
||||
;; ── do-let ──
|
||||
(hk-test
|
||||
"do-let single binding"
|
||||
(hk-eval-expr-source
|
||||
"do\n let x = 3\n return (x * 2)")
|
||||
(list "IO" 6))
|
||||
|
||||
(hk-test
|
||||
"do-let multi-bind, used after"
|
||||
(hk-eval-expr-source
|
||||
"do\n let x = 4\n y = 5\n return (x * y)")
|
||||
(list "IO" 20))
|
||||
|
||||
(hk-test
|
||||
"do-let interleaved with bind"
|
||||
(hk-eval-expr-source
|
||||
"do\n x <- return 10\n let y = x + 1\n return (x * y)")
|
||||
(list "IO" 110))
|
||||
|
||||
;; ── Bind + pattern ──
|
||||
(hk-test
|
||||
"bind to constructor pattern"
|
||||
(hk-eval-expr-source
|
||||
"do\n Just x <- return (Just 7)\n return (x + 100)")
|
||||
(list "IO" 107))
|
||||
|
||||
(hk-test
|
||||
"bind to tuple pattern"
|
||||
(hk-eval-expr-source
|
||||
"do\n (a, b) <- return (3, 4)\n return (a * b)")
|
||||
(list "IO" 12))
|
||||
|
||||
;; ── User-defined IO functions ──
|
||||
(hk-test
|
||||
"do inside top-level fun"
|
||||
(hk-prog-val
|
||||
"addM x y = do\n a <- return x\n b <- return y\n return (a + b)\nresult = addM 5 6"
|
||||
"result")
|
||||
(list "IO" 11))
|
||||
|
||||
(hk-test
|
||||
"nested do"
|
||||
(hk-eval-expr-source
|
||||
"do\n x <- do { y <- return 3 ; return (y + 1) }\n return (x * 2)")
|
||||
(list "IO" 8))
|
||||
|
||||
;; ── (>>=) and (>>) used directly as functions ──
|
||||
(hk-test
|
||||
">>= used directly"
|
||||
(hk-eval-expr-source
|
||||
"(return 4) >>= (\\x -> return (x + 100))")
|
||||
(list "IO" 104))
|
||||
|
||||
(hk-test
|
||||
">> used directly"
|
||||
(hk-eval-expr-source
|
||||
"(return 1) >> (return 2)")
|
||||
(list "IO" 2))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,278 +0,0 @@
|
||||
;; Strict evaluator tests. Each test parses, desugars, and evaluates
|
||||
;; either an expression (hk-eval-expr-source) or a full program
|
||||
;; (hk-eval-program → look up a named value).
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
;; ── Literals ──
|
||||
(hk-test "int literal" (hk-eval-expr-source "42") 42)
|
||||
(hk-test "float literal" (hk-eval-expr-source "3.14") 3.14)
|
||||
(hk-test "string literal" (hk-eval-expr-source "\"hi\"") "hi")
|
||||
(hk-test "char literal" (hk-eval-expr-source "'a'") "a")
|
||||
(hk-test "negative literal" (hk-eval-expr-source "- 5") -5)
|
||||
|
||||
;; ── Arithmetic ──
|
||||
(hk-test "addition" (hk-eval-expr-source "1 + 2") 3)
|
||||
(hk-test
|
||||
"precedence"
|
||||
(hk-eval-expr-source "1 + 2 * 3")
|
||||
7)
|
||||
(hk-test
|
||||
"parens override precedence"
|
||||
(hk-eval-expr-source "(1 + 2) * 3")
|
||||
9)
|
||||
(hk-test
|
||||
"subtraction left-assoc"
|
||||
(hk-eval-expr-source "10 - 3 - 2")
|
||||
5)
|
||||
|
||||
;; ── Comparison + Bool ──
|
||||
(hk-test
|
||||
"less than is True"
|
||||
(hk-eval-expr-source "3 < 5")
|
||||
(list "True"))
|
||||
(hk-test
|
||||
"equality is False"
|
||||
(hk-eval-expr-source "1 == 2")
|
||||
(list "False"))
|
||||
(hk-test
|
||||
"&& shortcuts"
|
||||
(hk-eval-expr-source "(1 == 1) && (2 == 2)")
|
||||
(list "True"))
|
||||
|
||||
;; ── if / otherwise ──
|
||||
(hk-test
|
||||
"if True"
|
||||
(hk-eval-expr-source "if True then 1 else 2")
|
||||
1)
|
||||
(hk-test
|
||||
"if comparison branch"
|
||||
(hk-eval-expr-source "if 5 > 3 then \"yes\" else \"no\"")
|
||||
"yes")
|
||||
(hk-test "otherwise is True" (hk-eval-expr-source "otherwise") (list "True"))
|
||||
|
||||
;; ── let ──
|
||||
(hk-test
|
||||
"let single binding"
|
||||
(hk-eval-expr-source "let x = 5 in x + 1")
|
||||
6)
|
||||
(hk-test
|
||||
"let two bindings"
|
||||
(hk-eval-expr-source "let x = 1; y = 2 in x + y")
|
||||
3)
|
||||
(hk-test
|
||||
"let recursive: factorial 5"
|
||||
(hk-eval-expr-source
|
||||
"let f n = if n == 0 then 1 else n * f (n - 1) in f 5")
|
||||
120)
|
||||
|
||||
;; ── Lambdas ──
|
||||
(hk-test
|
||||
"lambda apply"
|
||||
(hk-eval-expr-source "(\\x -> x + 1) 5")
|
||||
6)
|
||||
(hk-test
|
||||
"lambda multi-arg"
|
||||
(hk-eval-expr-source "(\\x y -> x * y) 3 4")
|
||||
12)
|
||||
(hk-test
|
||||
"lambda with constructor pattern"
|
||||
(hk-eval-expr-source "(\\(Just x) -> x + 1) (Just 7)")
|
||||
8)
|
||||
|
||||
;; ── Constructors ──
|
||||
(hk-test
|
||||
"0-arity constructor"
|
||||
(hk-eval-expr-source "Nothing")
|
||||
(list "Nothing"))
|
||||
(hk-test
|
||||
"1-arity constructor applied"
|
||||
(hk-eval-expr-source "Just 5")
|
||||
(list "Just" 5))
|
||||
(hk-test
|
||||
"True / False as bools"
|
||||
(hk-eval-expr-source "True")
|
||||
(list "True"))
|
||||
|
||||
;; ── case ──
|
||||
(hk-test
|
||||
"case Just"
|
||||
(hk-eval-expr-source
|
||||
"case Just 7 of Just x -> x ; Nothing -> 0")
|
||||
7)
|
||||
(hk-test
|
||||
"case Nothing"
|
||||
(hk-eval-expr-source
|
||||
"case Nothing of Just x -> x ; Nothing -> 99")
|
||||
99)
|
||||
(hk-test
|
||||
"case literal pattern"
|
||||
(hk-eval-expr-source
|
||||
"case 0 of 0 -> \"zero\" ; n -> \"other\"")
|
||||
"zero")
|
||||
(hk-test
|
||||
"case tuple"
|
||||
(hk-eval-expr-source
|
||||
"case (1, 2) of (a, b) -> a + b")
|
||||
3)
|
||||
(hk-test
|
||||
"case wildcard fallback"
|
||||
(hk-eval-expr-source
|
||||
"case 5 of 0 -> \"z\" ; _ -> \"nz\"")
|
||||
"nz")
|
||||
|
||||
;; ── List literals + cons ──
|
||||
(hk-test
|
||||
"list literal as cons spine"
|
||||
(hk-eval-expr-source "[1, 2, 3]")
|
||||
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
|
||||
(hk-test
|
||||
"empty list literal"
|
||||
(hk-eval-expr-source "[]")
|
||||
(list "[]"))
|
||||
(hk-test
|
||||
"cons via :"
|
||||
(hk-eval-expr-source "1 : []")
|
||||
(list ":" 1 (list "[]")))
|
||||
(hk-test
|
||||
"++ concatenates lists"
|
||||
(hk-eval-expr-source "[1, 2] ++ [3]")
|
||||
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
|
||||
|
||||
;; ── Tuples ──
|
||||
(hk-test
|
||||
"2-tuple"
|
||||
(hk-eval-expr-source "(1, 2)")
|
||||
(list "Tuple" 1 2))
|
||||
(hk-test
|
||||
"3-tuple"
|
||||
(hk-eval-expr-source "(\"a\", 5, True)")
|
||||
(list "Tuple" "a" 5 (list "True")))
|
||||
|
||||
;; ── Sections ──
|
||||
(hk-test
|
||||
"right section (+ 1) applied"
|
||||
(hk-eval-expr-source "(+ 1) 5")
|
||||
6)
|
||||
(hk-test
|
||||
"left section (10 -) applied"
|
||||
(hk-eval-expr-source "(10 -) 4")
|
||||
6)
|
||||
|
||||
;; ── Multi-clause top-level functions ──
|
||||
(hk-test
|
||||
"multi-clause: factorial"
|
||||
(hk-prog-val
|
||||
"fact 0 = 1\nfact n = n * fact (n - 1)\nresult = fact 6"
|
||||
"result")
|
||||
720)
|
||||
|
||||
(hk-test
|
||||
"multi-clause: list length via cons pattern"
|
||||
(hk-prog-val
|
||||
"len [] = 0\nlen (x:xs) = 1 + len xs\nresult = len [10, 20, 30, 40]"
|
||||
"result")
|
||||
4)
|
||||
|
||||
(hk-test
|
||||
"multi-clause: Maybe handler"
|
||||
(hk-prog-val
|
||||
"fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 (Just 9)"
|
||||
"result")
|
||||
9)
|
||||
|
||||
(hk-test
|
||||
"multi-clause: Maybe with default"
|
||||
(hk-prog-val
|
||||
"fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 Nothing"
|
||||
"result")
|
||||
0)
|
||||
|
||||
;; ── User-defined data and matching ──
|
||||
(hk-test
|
||||
"custom data with pattern match"
|
||||
(hk-prog-val
|
||||
"data Color = Red | Green | Blue\nname Red = \"red\"\nname Green = \"green\"\nname Blue = \"blue\"\nresult = name Green"
|
||||
"result")
|
||||
"green")
|
||||
|
||||
(hk-test
|
||||
"custom binary tree height"
|
||||
(hk-prog-val
|
||||
"data Tree = Leaf | Node Tree Tree\nh Leaf = 0\nh (Node l r) = 1 + max (h l) (h r)\nmax a b = if a > b then a else b\nresult = h (Node (Node Leaf Leaf) Leaf)"
|
||||
"result")
|
||||
2)
|
||||
|
||||
;; ── Currying ──
|
||||
(hk-test
|
||||
"partial application"
|
||||
(hk-prog-val
|
||||
"add x y = x + y\nadd5 = add 5\nresult = add5 7"
|
||||
"result")
|
||||
12)
|
||||
|
||||
;; ── Higher-order ──
|
||||
(hk-test
|
||||
"higher-order: function as arg"
|
||||
(hk-prog-val
|
||||
"twice f x = f (f x)\ninc x = x + 1\nresult = twice inc 10"
|
||||
"result")
|
||||
12)
|
||||
|
||||
;; ── Error built-in ──
|
||||
(hk-test
|
||||
"error short-circuits via if"
|
||||
(hk-eval-expr-source
|
||||
"if True then 1 else error \"unreachable\"")
|
||||
1)
|
||||
|
||||
;; ── Laziness: app args evaluate only when forced ──
|
||||
(hk-test
|
||||
"second arg never forced"
|
||||
(hk-eval-expr-source
|
||||
"(\\x y -> x) 1 (error \"never\")")
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"first arg never forced"
|
||||
(hk-eval-expr-source
|
||||
"(\\x y -> y) (error \"never\") 99")
|
||||
99)
|
||||
|
||||
(hk-test
|
||||
"constructor argument is lazy under wildcard pattern"
|
||||
(hk-eval-expr-source
|
||||
"case Just (error \"deeply\") of Just _ -> 7 ; Nothing -> 0")
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"lazy: const drops its second argument"
|
||||
(hk-prog-val
|
||||
"const x y = x\nresult = const 5 (error \"boom\")"
|
||||
"result")
|
||||
5)
|
||||
|
||||
(hk-test
|
||||
"lazy: head ignores tail"
|
||||
(hk-prog-val
|
||||
"myHead (x:_) = x\nresult = myHead (1 : (error \"tail\") : [])"
|
||||
"result")
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"lazy: Just on undefined evaluates only on force"
|
||||
(hk-prog-val
|
||||
"wrapped = Just (error \"oh no\")\nresult = case wrapped of Just _ -> True ; Nothing -> False"
|
||||
"result")
|
||||
(list "True"))
|
||||
|
||||
;; ── not / id built-ins ──
|
||||
(hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
|
||||
(hk-test "not False" (hk-eval-expr-source "not False") (list "True"))
|
||||
(hk-test "id" (hk-eval-expr-source "id 42") 42)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,137 +0,0 @@
|
||||
;; Infinite structures + Prelude tests. The lazy `:` operator builds
|
||||
;; cons cells with thunked head/tail so recursive list-defining
|
||||
;; functions terminate when only a finite prefix is consumed.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define hk-as-list
|
||||
(fn (xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(define
|
||||
hk-eval-list
|
||||
(fn (src) (hk-as-list (hk-eval-expr-source src))))
|
||||
|
||||
;; ── Prelude basics ──
|
||||
(hk-test "head of literal" (hk-eval-expr-source "head [1, 2, 3]") 1)
|
||||
(hk-test
|
||||
"tail of literal"
|
||||
(hk-eval-list "tail [1, 2, 3]")
|
||||
(list 2 3))
|
||||
(hk-test "length" (hk-eval-expr-source "length [10, 20, 30, 40]") 4)
|
||||
(hk-test "length empty" (hk-eval-expr-source "length []") 0)
|
||||
(hk-test
|
||||
"map with section"
|
||||
(hk-eval-list "map (+ 1) [1, 2, 3]")
|
||||
(list 2 3 4))
|
||||
(hk-test
|
||||
"filter"
|
||||
(hk-eval-list "filter (\\x -> x > 2) [1, 2, 3, 4, 5]")
|
||||
(list 3 4 5))
|
||||
(hk-test
|
||||
"drop"
|
||||
(hk-eval-list "drop 2 [10, 20, 30, 40]")
|
||||
(list 30 40))
|
||||
(hk-test "fst" (hk-eval-expr-source "fst (7, 9)") 7)
|
||||
(hk-test "snd" (hk-eval-expr-source "snd (7, 9)") 9)
|
||||
(hk-test
|
||||
"zipWith"
|
||||
(hk-eval-list "zipWith plus [1, 2, 3] [10, 20, 30]")
|
||||
(list 11 22 33))
|
||||
|
||||
;; ── Infinite structures ──
|
||||
(hk-test
|
||||
"take from repeat"
|
||||
(hk-eval-list "take 5 (repeat 7)")
|
||||
(list 7 7 7 7 7))
|
||||
(hk-test
|
||||
"take 0 from repeat returns empty"
|
||||
(hk-eval-list "take 0 (repeat 7)")
|
||||
(list))
|
||||
(hk-test
|
||||
"take from iterate"
|
||||
(hk-eval-list "take 5 (iterate (\\x -> x + 1) 0)")
|
||||
(list 0 1 2 3 4))
|
||||
(hk-test
|
||||
"iterate with multiplication"
|
||||
(hk-eval-list "take 4 (iterate (\\x -> x * 2) 1)")
|
||||
(list 1 2 4 8))
|
||||
(hk-test
|
||||
"head of repeat"
|
||||
(hk-eval-expr-source "head (repeat 99)")
|
||||
99)
|
||||
|
||||
;; ── Fibonacci stream ──
|
||||
(hk-test
|
||||
"first 10 Fibonacci numbers"
|
||||
(hk-eval-list "take 10 fibs")
|
||||
(list 0 1 1 2 3 5 8 13 21 34))
|
||||
(hk-test
|
||||
"fib at position 8"
|
||||
(hk-eval-expr-source "head (drop 8 fibs)")
|
||||
21)
|
||||
|
||||
;; ── Building infinite structures in user code ──
|
||||
(hk-test
|
||||
"user-defined infinite ones"
|
||||
(hk-prog-val
|
||||
"ones = 1 : ones\nresult = take 6 ones"
|
||||
"result")
|
||||
(list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list "[]"))))))))
|
||||
|
||||
(hk-test
|
||||
"user-defined nats"
|
||||
(hk-prog-val
|
||||
"nats = naturalsFrom 1\nnaturalsFrom n = n : naturalsFrom (n + 1)\nresult = take 5 nats"
|
||||
"result")
|
||||
(list ":" 1 (list ":" 2 (list ":" 3 (list ":" 4 (list ":" 5 (list "[]")))))))
|
||||
|
||||
;; ── Range syntax ──
|
||||
(hk-test
|
||||
"finite range [1..5]"
|
||||
(hk-eval-list "[1..5]")
|
||||
(list 1 2 3 4 5))
|
||||
(hk-test
|
||||
"empty range when from > to"
|
||||
(hk-eval-list "[10..3]")
|
||||
(list))
|
||||
(hk-test
|
||||
"stepped range"
|
||||
(hk-eval-list "[1, 3..10]")
|
||||
(list 1 3 5 7 9))
|
||||
(hk-test
|
||||
"open range — head"
|
||||
(hk-eval-expr-source "head [1..]")
|
||||
1)
|
||||
(hk-test
|
||||
"open range — drop then head"
|
||||
(hk-eval-expr-source "head (drop 99 [1..])")
|
||||
100)
|
||||
(hk-test
|
||||
"open range — take 5"
|
||||
(hk-eval-list "take 5 [10..]")
|
||||
(list 10 11 12 13 14))
|
||||
|
||||
;; ── Composing Prelude functions ──
|
||||
(hk-test
|
||||
"map then filter"
|
||||
(hk-eval-list
|
||||
"filter (\\x -> x > 5) (map (\\x -> x * 2) [1, 2, 3, 4])")
|
||||
(list 6 8))
|
||||
|
||||
(hk-test
|
||||
"sum-via-foldless"
|
||||
(hk-prog-val
|
||||
"mySum [] = 0\nmySum (x:xs) = x + mySum xs\nresult = mySum (take 5 (iterate (\\x -> x + 1) 1))"
|
||||
"result")
|
||||
15)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,245 +0,0 @@
|
||||
;; Haskell layout-rule tests. hk-tokenizer + hk-layout produce a
|
||||
;; virtual-brace-annotated stream; these tests cover the algorithm
|
||||
;; from Haskell 98 §10.3 plus the pragmatic let/in single-line rule.
|
||||
|
||||
;; Convenience — tokenize, run layout, strip eof, keep :type/:value.
|
||||
(define
|
||||
hk-lay
|
||||
(fn
|
||||
(src)
|
||||
(map
|
||||
(fn (tok) {:value (get tok "value") :type (get tok "type")})
|
||||
(filter
|
||||
(fn (tok) (not (= (get tok "type") "eof")))
|
||||
(hk-layout (hk-tokenize src))))))
|
||||
|
||||
;; ── 1. Basics ──
|
||||
(hk-test
|
||||
"empty input produces empty module { }"
|
||||
(hk-lay "")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"single token → module open+close"
|
||||
(hk-lay "foo")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"two top-level decls get vsemi between"
|
||||
(hk-lay "foo = 1\nbar = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "bar" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 2. Layout keywords — do / let / where / of ──
|
||||
(hk-test
|
||||
"do block with two stmts"
|
||||
(hk-lay "f = do\n x\n y")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"single-line let ... in"
|
||||
(hk-lay "let x = 1 in x")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "let" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "in" :type "reserved"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"where block with two bindings"
|
||||
(hk-lay "f = g\n where\n g = 1\n h = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "h" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"case … of with arms"
|
||||
(hk-lay "f x = case x of\n Just y -> y\n Nothing -> 0")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "case" :type "reserved"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "of" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "Just" :type "conid"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "->" :type "reservedop"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "Nothing" :type "conid"}
|
||||
{:value "->" :type "reservedop"}
|
||||
{:value 0 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 3. Explicit braces disable layout ──
|
||||
(hk-test
|
||||
"explicit braces — no implicit vlbrace/vsemi/vrbrace inside"
|
||||
(hk-lay "do { x ; y }")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "lbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "semi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "rbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 4. Dedent closes nested blocks ──
|
||||
(hk-test
|
||||
"dedent back to module level closes do block"
|
||||
(hk-lay "f = do\n x\n y\ng = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"dedent closes inner let, emits vsemi at outer do level"
|
||||
(hk-lay "main = do\n let x = 1\n print x")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "main" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "let" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "print" :type "varid"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 5. Module header skips outer implicit open ──
|
||||
(hk-test
|
||||
"module M where — only where opens a block"
|
||||
(hk-lay "module M where\n f = 1")
|
||||
(list
|
||||
{:value "module" :type "reserved"}
|
||||
{:value "M" :type "conid"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 6. Newlines are stripped ──
|
||||
(hk-test
|
||||
"newline tokens do not appear in output"
|
||||
(let
|
||||
((toks (hk-layout (hk-tokenize "foo\nbar"))))
|
||||
(every?
|
||||
(fn (t) (not (= (get t "type") "newline")))
|
||||
toks))
|
||||
true)
|
||||
|
||||
;; ── 7. Continuation — deeper indent does NOT emit vsemi ──
|
||||
(hk-test
|
||||
"line continuation (deeper indent) just merges"
|
||||
(hk-lay "foo = 1 +\n 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "+" :type "varsym"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 8. Stack closing at EOF ──
|
||||
(hk-test
|
||||
"EOF inside nested do closes all implicit blocks"
|
||||
(let
|
||||
((toks (hk-lay "main = do\n do\n x")))
|
||||
(let
|
||||
((n (len toks)))
|
||||
(list
|
||||
(get (nth toks (- n 1)) "type")
|
||||
(get (nth toks (- n 2)) "type")
|
||||
(get (nth toks (- n 3)) "type"))))
|
||||
(list "vrbrace" "vrbrace" "vrbrace"))
|
||||
|
||||
;; ── 9. Qualified-newline: x at deeper col than stack top does nothing ──
|
||||
(hk-test
|
||||
"mixed where + do"
|
||||
(hk-lay "f = do\n x\n where\n x = 1")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,256 +0,0 @@
|
||||
;; Pattern-matcher tests. The matcher takes (pat val env) and returns
|
||||
;; an extended env dict on success, or `nil` on failure. Constructor
|
||||
;; values are tagged lists (con-name first); tuples use the "Tuple"
|
||||
;; tag; lists use chained `:` cons with `[]` nil.
|
||||
|
||||
;; ── Atomic patterns ──
|
||||
(hk-test
|
||||
"wildcard always matches"
|
||||
(hk-match (list :p-wild) 42 (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"var binds value"
|
||||
(hk-match (list :p-var "x") 42 (dict))
|
||||
{:x 42})
|
||||
|
||||
(hk-test
|
||||
"var preserves prior env"
|
||||
(hk-match (list :p-var "y") 7 {:x 1})
|
||||
{:x 1 :y 7})
|
||||
|
||||
(hk-test
|
||||
"int literal matches equal"
|
||||
(hk-match (list :p-int 5) 5 (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"int literal fails on mismatch"
|
||||
(hk-match (list :p-int 5) 6 (dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"negative int literal matches"
|
||||
(hk-match (list :p-int -3) -3 (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"string literal matches"
|
||||
(hk-match (list :p-string "hi") "hi" (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"string literal fails"
|
||||
(hk-match (list :p-string "hi") "bye" (dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"char literal matches"
|
||||
(hk-match (list :p-char "a") "a" (dict))
|
||||
(dict))
|
||||
|
||||
;; ── Constructor patterns ──
|
||||
(hk-test
|
||||
"0-arity con matches"
|
||||
(hk-match
|
||||
(list :p-con "Nothing" (list))
|
||||
(hk-mk-con "Nothing" (list))
|
||||
(dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"1-arity con matches and binds"
|
||||
(hk-match
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(hk-mk-con "Just" (list 9))
|
||||
(dict))
|
||||
{:y 9})
|
||||
|
||||
(hk-test
|
||||
"con name mismatch fails"
|
||||
(hk-match
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(hk-mk-con "Nothing" (list))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"con arity mismatch fails"
|
||||
(hk-match
|
||||
(list :p-con "Pair" (list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-con "Pair" (list 1))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"nested con: Just (Just x)"
|
||||
(hk-match
|
||||
(list
|
||||
:p-con
|
||||
"Just"
|
||||
(list
|
||||
(list
|
||||
:p-con
|
||||
"Just"
|
||||
(list (list :p-var "x")))))
|
||||
(hk-mk-con "Just" (list (hk-mk-con "Just" (list 42))))
|
||||
(dict))
|
||||
{:x 42})
|
||||
|
||||
;; ── Tuple patterns ──
|
||||
(hk-test
|
||||
"2-tuple matches and binds"
|
||||
(hk-match
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-tuple (list 10 20))
|
||||
(dict))
|
||||
{:a 10 :b 20})
|
||||
|
||||
(hk-test
|
||||
"tuple arity mismatch fails"
|
||||
(hk-match
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-tuple (list 10 20 30))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; ── List patterns ──
|
||||
(hk-test
|
||||
"[] pattern matches empty list"
|
||||
(hk-match (list :p-list (list)) (hk-mk-nil) (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"[] pattern fails on non-empty"
|
||||
(hk-match (list :p-list (list)) (hk-mk-list (list 1)) (dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"[a] pattern matches singleton"
|
||||
(hk-match
|
||||
(list :p-list (list (list :p-var "a")))
|
||||
(hk-mk-list (list 7))
|
||||
(dict))
|
||||
{:a 7})
|
||||
|
||||
(hk-test
|
||||
"[a, b] pattern matches pair-list and binds"
|
||||
(hk-match
|
||||
(list
|
||||
:p-list
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-list (list 1 2))
|
||||
(dict))
|
||||
{:a 1 :b 2})
|
||||
|
||||
(hk-test
|
||||
"[a, b] fails on too-long list"
|
||||
(hk-match
|
||||
(list
|
||||
:p-list
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-list (list 1 2 3))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; Cons-style infix pattern (which the parser produces as :p-con ":")
|
||||
(hk-test
|
||||
"cons (h:t) on non-empty list"
|
||||
(hk-match
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "h") (list :p-var "t")))
|
||||
(hk-mk-list (list 1 2 3))
|
||||
(dict))
|
||||
{:h 1 :t (list ":" 2 (list ":" 3 (list "[]")))})
|
||||
|
||||
(hk-test
|
||||
"cons fails on empty list"
|
||||
(hk-match
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "h") (list :p-var "t")))
|
||||
(hk-mk-nil)
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; ── as patterns ──
|
||||
(hk-test
|
||||
"as binds whole + sub-pattern"
|
||||
(hk-match
|
||||
(list
|
||||
:p-as
|
||||
"all"
|
||||
(list :p-con "Just" (list (list :p-var "x"))))
|
||||
(hk-mk-con "Just" (list 99))
|
||||
(dict))
|
||||
{:all (list "Just" 99) :x 99})
|
||||
|
||||
(hk-test
|
||||
"as on wildcard binds whole"
|
||||
(hk-match
|
||||
(list :p-as "v" (list :p-wild))
|
||||
"anything"
|
||||
(dict))
|
||||
{:v "anything"})
|
||||
|
||||
(hk-test
|
||||
"as fails when sub-pattern fails"
|
||||
(hk-match
|
||||
(list
|
||||
:p-as
|
||||
"n"
|
||||
(list :p-con "Just" (list (list :p-var "x"))))
|
||||
(hk-mk-con "Nothing" (list))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; ── lazy ~ pattern (eager equivalent for now) ──
|
||||
(hk-test
|
||||
"lazy pattern eager-matches its inner"
|
||||
(hk-match
|
||||
(list :p-lazy (list :p-var "y"))
|
||||
42
|
||||
(dict))
|
||||
{:y 42})
|
||||
|
||||
;; ── Source-driven: parse a real Haskell pattern, match a value ──
|
||||
(hk-test
|
||||
"parsed pattern: Just x against Just 5"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "Just x")
|
||||
(hk-mk-con "Just" (list 5))
|
||||
(dict))
|
||||
{:x 5})
|
||||
|
||||
(hk-test
|
||||
"parsed pattern: x : xs against [10, 20, 30]"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "x : xs")
|
||||
(hk-mk-list (list 10 20 30))
|
||||
(dict))
|
||||
{:x 10 :xs (list ":" 20 (list ":" 30 (list "[]")))})
|
||||
|
||||
(hk-test
|
||||
"parsed pattern: (a, b) against (1, 2)"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "(a, b)")
|
||||
(hk-mk-tuple (list 1 2))
|
||||
(dict))
|
||||
{:a 1 :b 2})
|
||||
|
||||
(hk-test
|
||||
"parsed pattern: n@(Just x) against Just 7"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "n@(Just x)")
|
||||
(hk-mk-con "Just" (list 7))
|
||||
(dict))
|
||||
{:n (list "Just" 7) :x 7})
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -3,8 +3,60 @@
|
||||
;; Lightweight runner: each test checks actual vs expected with
|
||||
;; structural (deep) equality and accumulates pass/fail counters.
|
||||
;; Final value of this file is a summary dict with :pass :fail :fails.
|
||||
;; The hk-test / hk-deep=? helpers live in lib/haskell/testlib.sx
|
||||
;; and are preloaded by lib/haskell/test.sh.
|
||||
|
||||
(define
|
||||
hk-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn
|
||||
(k)
|
||||
(and (has-key? b k) (hk-deep=? (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
hk-de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (hk-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(hk-de-loop)))))
|
||||
(hk-de-loop)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define hk-test-pass 0)
|
||||
(define hk-test-fail 0)
|
||||
(define hk-test-fails (list))
|
||||
|
||||
(define
|
||||
hk-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(hk-deep=? actual expected)
|
||||
(set! hk-test-pass (+ hk-test-pass 1))
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append! hk-test-fails {:actual actual :expected expected :name name})))))
|
||||
|
||||
;; Convenience: tokenize and drop newline + eof tokens so tests focus
|
||||
;; on meaningful content. Returns list of {:type :value} pairs.
|
||||
|
||||
@@ -1,278 +0,0 @@
|
||||
;; case-of and do-notation parser tests.
|
||||
;; Covers the minimal patterns needed to make these meaningful: var,
|
||||
;; wildcard, literal, constructor (with and without args), tuple, list.
|
||||
|
||||
;; ── Patterns (in case arms) ──
|
||||
(hk-test
|
||||
"wildcard pat"
|
||||
(hk-parse "case x of _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list (list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"var pat"
|
||||
(hk-parse "case x of y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-var "y") (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"0-arity constructor pat"
|
||||
(hk-parse "case x of\n Nothing -> 0\n Just y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0))
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"int literal pat"
|
||||
(hk-parse "case n of\n 0 -> 1\n _ -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "n")
|
||||
(list
|
||||
(list :alt (list :p-int 0) (list :int 1))
|
||||
(list :alt (list :p-wild) (list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"string literal pat"
|
||||
(hk-parse "case s of\n \"hi\" -> 1\n _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "s")
|
||||
(list
|
||||
(list :alt (list :p-string "hi") (list :int 1))
|
||||
(list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"tuple pat"
|
||||
(hk-parse "case p of (a, b) -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "p")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
(hk-test
|
||||
"list pat"
|
||||
(hk-parse "case xs of\n [] -> 0\n [a] -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list :alt (list :p-list (list)) (list :int 0))
|
||||
(list
|
||||
:alt
|
||||
(list :p-list (list (list :p-var "a")))
|
||||
(list :var "a")))))
|
||||
|
||||
(hk-test
|
||||
"nested constructor pat"
|
||||
(hk-parse "case x of\n Just (a, b) -> a\n _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
"Just"
|
||||
(list
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))))
|
||||
(list :var "a"))
|
||||
(list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"constructor with multiple var args"
|
||||
(hk-parse "case t of Pair a b -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "t")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
"Pair"
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
;; ── case-of shapes ──
|
||||
(hk-test
|
||||
"case with explicit braces"
|
||||
(hk-parse "case x of { Just y -> y ; Nothing -> 0 }")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y"))
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"case scrutinee is a full expression"
|
||||
(hk-parse "case f x + 1 of\n y -> y")
|
||||
(list
|
||||
:case
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :int 1))
|
||||
(list (list :alt (list :p-var "y") (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"case arm body is full expression"
|
||||
(hk-parse "case x of\n Just y -> y + 1")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :op "+" (list :var "y") (list :int 1))))))
|
||||
|
||||
;; ── do blocks ──
|
||||
(hk-test
|
||||
"do with two expressions"
|
||||
(hk-parse "do\n putStrLn \"hi\"\n return 0")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "putStrLn") (list :string "hi")))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :int 0))))))
|
||||
|
||||
(hk-test
|
||||
"do with bind"
|
||||
(hk-parse "do\n x <- getLine\n putStrLn x")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "x") (list :var "getLine"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "putStrLn") (list :var "x"))))))
|
||||
|
||||
(hk-test
|
||||
"do with let"
|
||||
(hk-parse "do\n let y = 5\n print y")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-let
|
||||
(list (list :bind (list :p-var "y") (list :int 5))))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "print") (list :var "y"))))))
|
||||
|
||||
(hk-test
|
||||
"do with multiple let bindings"
|
||||
(hk-parse "do\n let x = 1\n y = 2\n print (x + y)")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2))))
|
||||
(list
|
||||
:do-expr
|
||||
(list
|
||||
:app
|
||||
(list :var "print")
|
||||
(list :op "+" (list :var "x") (list :var "y")))))))
|
||||
|
||||
(hk-test
|
||||
"do with bind using constructor pat"
|
||||
(hk-parse "do\n Just x <- getMaybe\n return x")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-bind
|
||||
(list :p-con "Just" (list (list :p-var "x")))
|
||||
(list :var "getMaybe"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "x"))))))
|
||||
|
||||
(hk-test
|
||||
"do with explicit braces"
|
||||
(hk-parse "do { x <- a ; y <- b ; return (x + y) }")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "x") (list :var "a"))
|
||||
(list :do-bind (list :p-var "y") (list :var "b"))
|
||||
(list
|
||||
:do-expr
|
||||
(list
|
||||
:app
|
||||
(list :var "return")
|
||||
(list :op "+" (list :var "x") (list :var "y")))))))
|
||||
|
||||
;; ── Mixing case/do inside expressions ──
|
||||
(hk-test
|
||||
"case inside let"
|
||||
(hk-parse "let f = \\x -> case x of\n Just y -> y\n _ -> 0\nin f 5")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "f")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y"))
|
||||
(list :alt (list :p-wild) (list :int 0)))))))
|
||||
(list :app (list :var "f") (list :int 5))))
|
||||
|
||||
(hk-test
|
||||
"lambda containing do"
|
||||
(hk-parse "\\x -> do\n y <- x\n return y")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "y") (list :var "x"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "y")))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,273 +0,0 @@
|
||||
;; Top-level declarations: function clauses, type signatures, data,
|
||||
;; type, newtype, fixity. Driven by hk-parse-top which produces
|
||||
;; a (:program DECLS) node.
|
||||
|
||||
(define
|
||||
hk-prog
|
||||
(fn
|
||||
(&rest decls)
|
||||
(list :program decls)))
|
||||
|
||||
;; ── Function clauses & pattern bindings ──
|
||||
(hk-test
|
||||
"simple fun-clause"
|
||||
(hk-parse-top "f x = x + 1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"nullary decl"
|
||||
(hk-parse-top "answer = 42")
|
||||
(hk-prog
|
||||
(list :fun-clause "answer" (list) (list :int 42))))
|
||||
|
||||
(hk-test
|
||||
"multi-clause fn (separate defs for each pattern)"
|
||||
(hk-parse-top "fact 0 = 1\nfact n = n")
|
||||
(hk-prog
|
||||
(list :fun-clause "fact" (list (list :p-int 0)) (list :int 1))
|
||||
(list
|
||||
:fun-clause
|
||||
"fact"
|
||||
(list (list :p-var "n"))
|
||||
(list :var "n"))))
|
||||
|
||||
(hk-test
|
||||
"constructor pattern in fn args"
|
||||
(hk-parse-top "fromJust (Just x) = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"fromJust"
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x"))))
|
||||
|
||||
(hk-test
|
||||
"pattern binding at top level"
|
||||
(hk-parse-top "(a, b) = pair")
|
||||
(hk-prog
|
||||
(list
|
||||
:pat-bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "pair"))))
|
||||
|
||||
;; ── Type signatures ──
|
||||
(hk-test
|
||||
"single-name sig"
|
||||
(hk-parse-top "f :: Int -> Int")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list :t-fun (list :t-con "Int") (list :t-con "Int")))))
|
||||
|
||||
(hk-test
|
||||
"multi-name sig"
|
||||
(hk-parse-top "f, g, h :: Int -> Bool")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f" "g" "h")
|
||||
(list :t-fun (list :t-con "Int") (list :t-con "Bool")))))
|
||||
|
||||
(hk-test
|
||||
"sig with type application"
|
||||
(hk-parse-top "f :: Maybe a -> a")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-app (list :t-con "Maybe") (list :t-var "a"))
|
||||
(list :t-var "a")))))
|
||||
|
||||
(hk-test
|
||||
"sig with list type"
|
||||
(hk-parse-top "len :: [a] -> Int")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "len")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-list (list :t-var "a"))
|
||||
(list :t-con "Int")))))
|
||||
|
||||
(hk-test
|
||||
"sig with tuple and right-assoc ->"
|
||||
(hk-parse-top "pair :: a -> b -> (a, b)")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "pair")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-var "a")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-var "b")
|
||||
(list
|
||||
:t-tuple
|
||||
(list (list :t-var "a") (list :t-var "b"))))))))
|
||||
|
||||
(hk-test
|
||||
"sig + implementation together"
|
||||
(hk-parse-top "id :: a -> a\nid x = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "id")
|
||||
(list :t-fun (list :t-var "a") (list :t-var "a")))
|
||||
(list
|
||||
:fun-clause
|
||||
"id"
|
||||
(list (list :p-var "x"))
|
||||
(list :var "x"))))
|
||||
|
||||
;; ── data declarations ──
|
||||
(hk-test
|
||||
"data Maybe"
|
||||
(hk-parse-top "data Maybe a = Nothing | Just a")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Maybe"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Nothing" (list))
|
||||
(list :con-def "Just" (list (list :t-var "a")))))))
|
||||
|
||||
(hk-test
|
||||
"data Either"
|
||||
(hk-parse-top "data Either a b = Left a | Right b")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Either"
|
||||
(list "a" "b")
|
||||
(list
|
||||
(list :con-def "Left" (list (list :t-var "a")))
|
||||
(list :con-def "Right" (list (list :t-var "b")))))))
|
||||
|
||||
(hk-test
|
||||
"data with no type parameters"
|
||||
(hk-parse-top "data Bool = True | False")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Bool"
|
||||
(list)
|
||||
(list
|
||||
(list :con-def "True" (list))
|
||||
(list :con-def "False" (list))))))
|
||||
|
||||
(hk-test
|
||||
"recursive data type"
|
||||
(hk-parse-top "data Tree a = Leaf | Node (Tree a) a (Tree a)")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Tree"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Leaf" (list))
|
||||
(list
|
||||
:con-def
|
||||
"Node"
|
||||
(list
|
||||
(list :t-app (list :t-con "Tree") (list :t-var "a"))
|
||||
(list :t-var "a")
|
||||
(list :t-app (list :t-con "Tree") (list :t-var "a"))))))))
|
||||
|
||||
;; ── type synonyms ──
|
||||
(hk-test
|
||||
"simple type synonym"
|
||||
(hk-parse-top "type Name = String")
|
||||
(hk-prog
|
||||
(list :type-syn "Name" (list) (list :t-con "String"))))
|
||||
|
||||
(hk-test
|
||||
"parameterised type synonym"
|
||||
(hk-parse-top "type Pair a = (a, a)")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-syn
|
||||
"Pair"
|
||||
(list "a")
|
||||
(list
|
||||
:t-tuple
|
||||
(list (list :t-var "a") (list :t-var "a"))))))
|
||||
|
||||
;; ── newtype ──
|
||||
(hk-test
|
||||
"newtype"
|
||||
(hk-parse-top "newtype Age = Age Int")
|
||||
(hk-prog (list :newtype "Age" (list) "Age" (list :t-con "Int"))))
|
||||
|
||||
(hk-test
|
||||
"parameterised newtype"
|
||||
(hk-parse-top "newtype Wrap a = Wrap a")
|
||||
(hk-prog
|
||||
(list :newtype "Wrap" (list "a") "Wrap" (list :t-var "a"))))
|
||||
|
||||
;; ── fixity declarations ──
|
||||
(hk-test
|
||||
"infixl with precedence"
|
||||
(hk-parse-top "infixl 5 +:, -:")
|
||||
(hk-prog (list :fixity "l" 5 (list "+:" "-:"))))
|
||||
|
||||
(hk-test
|
||||
"infixr"
|
||||
(hk-parse-top "infixr 9 .")
|
||||
(hk-prog (list :fixity "r" 9 (list "."))))
|
||||
|
||||
(hk-test
|
||||
"infix (non-assoc) default prec"
|
||||
(hk-parse-top "infix ==")
|
||||
(hk-prog (list :fixity "n" 9 (list "=="))))
|
||||
|
||||
(hk-test
|
||||
"fixity with backtick operator name"
|
||||
(hk-parse-top "infixl 7 `div`")
|
||||
(hk-prog (list :fixity "l" 7 (list "div"))))
|
||||
|
||||
;; ── Several decls combined ──
|
||||
(hk-test
|
||||
"mixed: data + sig + fn + type"
|
||||
(hk-parse-top "data Maybe a = Nothing | Just a\ntype Entry = Maybe Int\nf :: Entry -> Int\nf (Just x) = x\nf Nothing = 0")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Maybe"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Nothing" (list))
|
||||
(list :con-def "Just" (list (list :t-var "a")))))
|
||||
(list
|
||||
:type-syn
|
||||
"Entry"
|
||||
(list)
|
||||
(list :t-app (list :t-con "Maybe") (list :t-con "Int")))
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list :t-fun (list :t-con "Entry") (list :t-con "Int")))
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x"))
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-con "Nothing" (list)))
|
||||
(list :int 0))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,258 +0,0 @@
|
||||
;; Haskell expression parser tests.
|
||||
;; hk-parse tokenises, runs layout, then parses. Output is an AST
|
||||
;; whose head is a keyword tag (evaluates to its string name).
|
||||
|
||||
;; ── 1. Literals ──
|
||||
(hk-test "integer" (hk-parse "42") (list :int 42))
|
||||
(hk-test "float" (hk-parse "3.14") (list :float 3.14))
|
||||
(hk-test "string" (hk-parse "\"hi\"") (list :string "hi"))
|
||||
(hk-test "char" (hk-parse "'a'") (list :char "a"))
|
||||
|
||||
;; ── 2. Variables and constructors ──
|
||||
(hk-test "varid" (hk-parse "foo") (list :var "foo"))
|
||||
(hk-test "conid" (hk-parse "Nothing") (list :con "Nothing"))
|
||||
(hk-test "qvarid" (hk-parse "Data.Map.lookup") (list :var "Data.Map.lookup"))
|
||||
(hk-test "qconid" (hk-parse "Data.Map") (list :con "Data.Map"))
|
||||
|
||||
;; ── 3. Parens / unit / tuple ──
|
||||
(hk-test "parens strip" (hk-parse "(42)") (list :int 42))
|
||||
(hk-test "unit" (hk-parse "()") (list :con "()"))
|
||||
(hk-test
|
||||
"2-tuple"
|
||||
(hk-parse "(1, 2)")
|
||||
(list :tuple (list (list :int 1) (list :int 2))))
|
||||
(hk-test
|
||||
"3-tuple"
|
||||
(hk-parse "(x, y, z)")
|
||||
(list
|
||||
:tuple
|
||||
(list (list :var "x") (list :var "y") (list :var "z"))))
|
||||
|
||||
;; ── 4. Lists ──
|
||||
(hk-test "empty list" (hk-parse "[]") (list :list (list)))
|
||||
(hk-test
|
||||
"singleton list"
|
||||
(hk-parse "[1]")
|
||||
(list :list (list (list :int 1))))
|
||||
(hk-test
|
||||
"list of ints"
|
||||
(hk-parse "[1, 2, 3]")
|
||||
(list
|
||||
:list
|
||||
(list (list :int 1) (list :int 2) (list :int 3))))
|
||||
(hk-test
|
||||
"range"
|
||||
(hk-parse "[1..10]")
|
||||
(list :range (list :int 1) (list :int 10)))
|
||||
(hk-test
|
||||
"range with step"
|
||||
(hk-parse "[1, 3..10]")
|
||||
(list
|
||||
:range-step
|
||||
(list :int 1)
|
||||
(list :int 3)
|
||||
(list :int 10)))
|
||||
|
||||
;; ── 5. Application ──
|
||||
(hk-test
|
||||
"one-arg app"
|
||||
(hk-parse "f x")
|
||||
(list :app (list :var "f") (list :var "x")))
|
||||
(hk-test
|
||||
"multi-arg app is left-assoc"
|
||||
(hk-parse "f x y z")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :var "y"))
|
||||
(list :var "z")))
|
||||
(hk-test
|
||||
"app with con"
|
||||
(hk-parse "Just 5")
|
||||
(list :app (list :con "Just") (list :int 5)))
|
||||
|
||||
;; ── 6. Infix operators ──
|
||||
(hk-test
|
||||
"simple +"
|
||||
(hk-parse "1 + 2")
|
||||
(list :op "+" (list :int 1) (list :int 2)))
|
||||
(hk-test
|
||||
"precedence: * binds tighter than +"
|
||||
(hk-parse "1 + 2 * 3")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :int 1)
|
||||
(list :op "*" (list :int 2) (list :int 3))))
|
||||
(hk-test
|
||||
"- is left-assoc"
|
||||
(hk-parse "10 - 3 - 2")
|
||||
(list
|
||||
:op
|
||||
"-"
|
||||
(list :op "-" (list :int 10) (list :int 3))
|
||||
(list :int 2)))
|
||||
(hk-test
|
||||
": is right-assoc"
|
||||
(hk-parse "a : b : c")
|
||||
(list
|
||||
:op
|
||||
":"
|
||||
(list :var "a")
|
||||
(list :op ":" (list :var "b") (list :var "c"))))
|
||||
(hk-test
|
||||
"app binds tighter than op"
|
||||
(hk-parse "f x + g y")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :app (list :var "g") (list :var "y"))))
|
||||
(hk-test
|
||||
"$ is lowest precedence, right-assoc"
|
||||
(hk-parse "f $ g x")
|
||||
(list
|
||||
:op
|
||||
"$"
|
||||
(list :var "f")
|
||||
(list :app (list :var "g") (list :var "x"))))
|
||||
|
||||
;; ── 7. Backticks (varid-as-operator) ──
|
||||
(hk-test
|
||||
"backtick operator"
|
||||
(hk-parse "x `mod` 3")
|
||||
(list :op "mod" (list :var "x") (list :int 3)))
|
||||
|
||||
;; ── 8. Unary negation ──
|
||||
(hk-test
|
||||
"unary -"
|
||||
(hk-parse "- 5")
|
||||
(list :neg (list :int 5)))
|
||||
(hk-test
|
||||
"unary - on application"
|
||||
(hk-parse "- f x")
|
||||
(list :neg (list :app (list :var "f") (list :var "x"))))
|
||||
(hk-test
|
||||
"- n + m → (- n) + m"
|
||||
(hk-parse "- 1 + 2")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :neg (list :int 1))
|
||||
(list :int 2)))
|
||||
|
||||
;; ── 9. Lambda ──
|
||||
(hk-test
|
||||
"lambda single param"
|
||||
(hk-parse "\\x -> x")
|
||||
(list :lambda (list (list :p-var "x")) (list :var "x")))
|
||||
(hk-test
|
||||
"lambda multi-param"
|
||||
(hk-parse "\\x y -> x + y")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x") (list :p-var "y"))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
(hk-test
|
||||
"lambda body is full expression"
|
||||
(hk-parse "\\f -> f 1 + f 2")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "f"))
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :int 1))
|
||||
(list :app (list :var "f") (list :int 2)))))
|
||||
|
||||
;; ── 10. if-then-else ──
|
||||
(hk-test
|
||||
"if basic"
|
||||
(hk-parse "if x then 1 else 2")
|
||||
(list :if (list :var "x") (list :int 1) (list :int 2)))
|
||||
(hk-test
|
||||
"if with infix cond"
|
||||
(hk-parse "if x == 0 then y else z")
|
||||
(list
|
||||
:if
|
||||
(list :op "==" (list :var "x") (list :int 0))
|
||||
(list :var "y")
|
||||
(list :var "z")))
|
||||
|
||||
;; ── 11. let-in ──
|
||||
(hk-test
|
||||
"let single binding"
|
||||
(hk-parse "let x = 1 in x")
|
||||
(list
|
||||
:let
|
||||
(list (list :bind (list :p-var "x") (list :int 1)))
|
||||
(list :var "x")))
|
||||
(hk-test
|
||||
"let two bindings (multi-line)"
|
||||
(hk-parse "let x = 1\n y = 2\nin x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2)))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
(hk-test
|
||||
"let with explicit braces"
|
||||
(hk-parse "let { x = 1 ; y = 2 } in x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2)))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
|
||||
;; ── 12. Mixed / nesting ──
|
||||
(hk-test
|
||||
"nested application"
|
||||
(hk-parse "f (g x) y")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "f")
|
||||
(list :app (list :var "g") (list :var "x")))
|
||||
(list :var "y")))
|
||||
(hk-test
|
||||
"lambda applied"
|
||||
(hk-parse "(\\x -> x + 1) 5")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1)))
|
||||
(list :int 5)))
|
||||
(hk-test
|
||||
"lambda + if"
|
||||
(hk-parse "\\n -> if n == 0 then 1 else n")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:if
|
||||
(list :op "==" (list :var "n") (list :int 0))
|
||||
(list :int 1)
|
||||
(list :var "n"))))
|
||||
|
||||
;; ── 13. Precedence corners ──
|
||||
(hk-test
|
||||
". is right-assoc (prec 9)"
|
||||
(hk-parse "f . g . h")
|
||||
(list
|
||||
:op
|
||||
"."
|
||||
(list :var "f")
|
||||
(list :op "." (list :var "g") (list :var "h"))))
|
||||
(hk-test
|
||||
"== is non-associative (single use)"
|
||||
(hk-parse "x == y")
|
||||
(list :op "==" (list :var "x") (list :var "y")))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,261 +0,0 @@
|
||||
;; Guards and where-clauses — on fun-clauses, case alts, and
|
||||
;; let-bindings (which now also accept funclause-style LHS like
|
||||
;; `let f x = e` or `let f x | g = e | g = e`).
|
||||
|
||||
(define
|
||||
hk-prog
|
||||
(fn (&rest decls) (list :program decls)))
|
||||
|
||||
;; ── Guarded fun-clauses ──
|
||||
(hk-test
|
||||
"simple guards (two branches)"
|
||||
(hk-parse-top "abs x | x < 0 = - x\n | otherwise = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"abs"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op "<" (list :var "x") (list :int 0))
|
||||
(list :neg (list :var "x")))
|
||||
(list :guard (list :var "otherwise") (list :var "x")))))))
|
||||
|
||||
(hk-test
|
||||
"three-way guard"
|
||||
(hk-parse-top "sign n | n > 0 = 1\n | n < 0 = -1\n | otherwise = 0")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "n") (list :int 0))
|
||||
(list :int 1))
|
||||
(list
|
||||
:guard
|
||||
(list :op "<" (list :var "n") (list :int 0))
|
||||
(list :neg (list :int 1)))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0)))))))
|
||||
|
||||
(hk-test
|
||||
"mixed: one eq clause plus one guarded clause"
|
||||
(hk-parse-top "sign 0 = 0\nsign n | n > 0 = 1\n | otherwise = -1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-int 0))
|
||||
(list :int 0))
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "n") (list :int 0))
|
||||
(list :int 1))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :neg (list :int 1))))))))
|
||||
|
||||
;; ── where on fun-clauses ──
|
||||
(hk-test
|
||||
"where with one binding"
|
||||
(hk-parse-top "f x = y + y\n where y = x + 1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :op "+" (list :var "y") (list :var "y"))
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1))))))))
|
||||
|
||||
(hk-test
|
||||
"where with multiple bindings"
|
||||
(hk-parse-top "f x = y * z\n where y = x + 1\n z = x - 1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :op "*" (list :var "y") (list :var "z"))
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1)))
|
||||
(list
|
||||
:fun-clause
|
||||
"z"
|
||||
(list)
|
||||
(list :op "-" (list :var "x") (list :int 1))))))))
|
||||
|
||||
(hk-test
|
||||
"guards + where"
|
||||
(hk-parse-top "f x | x > 0 = y\n | otherwise = 0\n where y = 99")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "y"))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0))))
|
||||
(list
|
||||
(list :fun-clause "y" (list) (list :int 99)))))))
|
||||
|
||||
;; ── Guards in case alts ──
|
||||
(hk-test
|
||||
"case alt with guards"
|
||||
(hk-parse "case x of\n Just y | y > 0 -> y\n | otherwise -> 0\n Nothing -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "y") (list :int 0))
|
||||
(list :var "y"))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0)))))
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"case alt with where"
|
||||
(hk-parse "case x of\n Just y -> y + z where z = 5\n Nothing -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list
|
||||
:where
|
||||
(list :op "+" (list :var "y") (list :var "z"))
|
||||
(list
|
||||
(list :fun-clause "z" (list) (list :int 5)))))
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
||||
|
||||
;; ── let-bindings: funclause form, guards, where ──
|
||||
(hk-test
|
||||
"let with funclause shorthand"
|
||||
(hk-parse "let f x = x + 1 in f 5")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1))))
|
||||
(list :app (list :var "f") (list :int 5))))
|
||||
|
||||
(hk-test
|
||||
"let with guards"
|
||||
(hk-parse "let f x | x > 0 = x\n | otherwise = 0\nin f 3")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "x"))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0))))))
|
||||
(list :app (list :var "f") (list :int 3))))
|
||||
|
||||
(hk-test
|
||||
"let funclause + where"
|
||||
(hk-parse "let f x = y where y = x + 1\nin f 7")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :var "y")
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1)))))))
|
||||
(list :app (list :var "f") (list :int 7))))
|
||||
|
||||
;; ── Nested: where inside where (via recursive hk-parse-decl) ──
|
||||
(hk-test
|
||||
"where block can contain a type signature"
|
||||
(hk-parse-top "f x = y\n where y :: Int\n y = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :var "y")
|
||||
(list
|
||||
(list :type-sig (list "y") (list :t-con "Int"))
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :var "x")))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,202 +0,0 @@
|
||||
;; Module header + imports. The parser switches from (:program DECLS)
|
||||
;; to (:module NAME EXPORTS IMPORTS DECLS) as soon as a module header
|
||||
;; or any `import` decl appears.
|
||||
|
||||
;; ── Module header ──
|
||||
(hk-test
|
||||
"simple module, no exports"
|
||||
(hk-parse-top "module M where\n f = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with dotted name"
|
||||
(hk-parse-top "module Data.Map where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"Data.Map"
|
||||
nil
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with empty export list"
|
||||
(hk-parse-top "module M () where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list)
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with exports (var, tycon-all, tycon-with)"
|
||||
(hk-parse-top "module M (f, g, Maybe(..), List(Cons, Nil)) where\nf = 1\ng = 2")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list
|
||||
(list :ent-var "f")
|
||||
(list :ent-var "g")
|
||||
(list :ent-all "Maybe")
|
||||
(list :ent-with "List" (list "Cons" "Nil")))
|
||||
(list)
|
||||
(list
|
||||
(list :fun-clause "f" (list) (list :int 1))
|
||||
(list :fun-clause "g" (list) (list :int 2)))))
|
||||
|
||||
(hk-test
|
||||
"module export list including another module"
|
||||
(hk-parse-top "module M (module Foo, f) where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list (list :ent-module "Foo") (list :ent-var "f"))
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module export with operator"
|
||||
(hk-parse-top "module M ((+:), f) where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list (list :ent-var "+:") (list :ent-var "f"))
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"empty module body"
|
||||
(hk-parse-top "module M where")
|
||||
(list :module "M" nil (list) (list)))
|
||||
|
||||
;; ── Imports ──
|
||||
(hk-test
|
||||
"plain import"
|
||||
(hk-parse-top "import Foo")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import false "Foo" nil nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"qualified import"
|
||||
(hk-parse-top "import qualified Data.Map")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import true "Data.Map" nil nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import with alias"
|
||||
(hk-parse-top "import Data.Map as M")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import false "Data.Map" "M" nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import with explicit list"
|
||||
(hk-parse-top "import Foo (bar, Baz(..), Quux(X, Y))")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Foo"
|
||||
nil
|
||||
(list
|
||||
:spec-items
|
||||
(list
|
||||
(list :ent-var "bar")
|
||||
(list :ent-all "Baz")
|
||||
(list :ent-with "Quux" (list "X" "Y"))))))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import hiding"
|
||||
(hk-parse-top "import Foo hiding (x, y)")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Foo"
|
||||
nil
|
||||
(list
|
||||
:spec-hiding
|
||||
(list (list :ent-var "x") (list :ent-var "y")))))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"qualified + alias + hiding"
|
||||
(hk-parse-top "import qualified Data.List as L hiding (sort)")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
true
|
||||
"Data.List"
|
||||
"L"
|
||||
(list :spec-hiding (list (list :ent-var "sort")))))
|
||||
(list)))
|
||||
|
||||
;; ── Combinations ──
|
||||
(hk-test
|
||||
"module with multiple imports and a decl"
|
||||
(hk-parse-top "module M where\nimport Foo\nimport qualified Bar as B\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list
|
||||
(list :import false "Foo" nil nil)
|
||||
(list :import true "Bar" "B" nil))
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"headerless file with imports"
|
||||
(hk-parse-top "import Foo\nimport Bar (baz)\nf = 1")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list :import false "Foo" nil nil)
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Bar"
|
||||
nil
|
||||
(list :spec-items (list (list :ent-var "baz")))))
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"plain program (no header, no imports) still uses :program"
|
||||
(hk-parse-top "f = 1\ng = 2")
|
||||
(list
|
||||
:program
|
||||
(list
|
||||
(list :fun-clause "f" (list) (list :int 1))
|
||||
(list :fun-clause "g" (list) (list :int 2)))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,234 +0,0 @@
|
||||
;; Full-pattern parser tests: as-patterns, lazy ~, negative literals,
|
||||
;; infix constructor patterns (`:`, any consym), lambda pattern args,
|
||||
;; and let pattern-bindings.
|
||||
|
||||
;; ── as-patterns ──
|
||||
(hk-test
|
||||
"as pattern, wraps constructor"
|
||||
(hk-parse "case x of n@(Just y) -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-as
|
||||
"n"
|
||||
(list :p-con "Just" (list (list :p-var "y"))))
|
||||
(list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"as pattern, wraps wildcard"
|
||||
(hk-parse "case x of all@_ -> all")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-as "all" (list :p-wild))
|
||||
(list :var "all")))))
|
||||
|
||||
(hk-test
|
||||
"as in lambda"
|
||||
(hk-parse "\\xs@(a : rest) -> xs")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-as
|
||||
"xs"
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "a") (list :p-var "rest")))))
|
||||
(list :var "xs")))
|
||||
|
||||
;; ── lazy patterns ──
|
||||
(hk-test
|
||||
"lazy var"
|
||||
(hk-parse "case x of ~y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-lazy (list :p-var "y")) (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"lazy constructor"
|
||||
(hk-parse "\\(~(Just x)) -> x")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-lazy
|
||||
(list :p-con "Just" (list (list :p-var "x")))))
|
||||
(list :var "x")))
|
||||
|
||||
;; ── negative literal patterns ──
|
||||
(hk-test
|
||||
"negative int pattern"
|
||||
(hk-parse "case n of\n -1 -> 0\n _ -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "n")
|
||||
(list
|
||||
(list :alt (list :p-int -1) (list :int 0))
|
||||
(list :alt (list :p-wild) (list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"negative float pattern"
|
||||
(hk-parse "case x of -0.5 -> 1")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list (list :alt (list :p-float -0.5) (list :int 1)))))
|
||||
|
||||
;; ── infix constructor patterns (`:` and any consym) ──
|
||||
(hk-test
|
||||
"cons pattern"
|
||||
(hk-parse "case xs of x : rest -> x")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "x") (list :p-var "rest")))
|
||||
(list :var "x")))))
|
||||
|
||||
(hk-test
|
||||
"cons is right-associative in pats"
|
||||
(hk-parse "case xs of a : b : rest -> rest")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list
|
||||
(list :p-var "a")
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "b") (list :p-var "rest")))))
|
||||
(list :var "rest")))))
|
||||
|
||||
(hk-test
|
||||
"consym pattern"
|
||||
(hk-parse "case p of a :+: b -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "p")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":+:"
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
;; ── lambda with pattern args ──
|
||||
(hk-test
|
||||
"lambda with constructor pattern"
|
||||
(hk-parse "\\(Just x) -> x")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"lambda with tuple pattern"
|
||||
(hk-parse "\\(a, b) -> a + b")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b"))))
|
||||
(list :op "+" (list :var "a") (list :var "b"))))
|
||||
|
||||
(hk-test
|
||||
"lambda with wildcard"
|
||||
(hk-parse "\\_ -> 42")
|
||||
(list :lambda (list (list :p-wild)) (list :int 42)))
|
||||
|
||||
(hk-test
|
||||
"lambda with mixed apats"
|
||||
(hk-parse "\\x _ (Just y) -> y")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list :p-var "x")
|
||||
(list :p-wild)
|
||||
(list :p-con "Just" (list (list :p-var "y"))))
|
||||
(list :var "y")))
|
||||
|
||||
;; ── let pattern-bindings ──
|
||||
(hk-test
|
||||
"let tuple pattern-binding"
|
||||
(hk-parse "let (x, y) = pair in x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "x") (list :p-var "y")))
|
||||
(list :var "pair")))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
|
||||
(hk-test
|
||||
"let constructor pattern-binding"
|
||||
(hk-parse "let Just x = m in x")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-con "Just" (list (list :p-var "x")))
|
||||
(list :var "m")))
|
||||
(list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"let cons pattern-binding"
|
||||
(hk-parse "let (x : rest) = xs in x")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "x") (list :p-var "rest")))
|
||||
(list :var "xs")))
|
||||
(list :var "x")))
|
||||
|
||||
;; ── do with constructor-pattern binds ──
|
||||
(hk-test
|
||||
"do bind to tuple pattern"
|
||||
(hk-parse "do\n (a, b) <- pairs\n return a")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "pairs"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "a"))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,191 +0,0 @@
|
||||
;; Operator sections and list comprehensions.
|
||||
|
||||
;; ── Operator references (unchanged expr shape) ──
|
||||
(hk-test
|
||||
"op as value (+)"
|
||||
(hk-parse "(+)")
|
||||
(list :var "+"))
|
||||
|
||||
(hk-test
|
||||
"op as value (-)"
|
||||
(hk-parse "(-)")
|
||||
(list :var "-"))
|
||||
|
||||
(hk-test
|
||||
"op as value (:)"
|
||||
(hk-parse "(:)")
|
||||
(list :var ":"))
|
||||
|
||||
(hk-test
|
||||
"backtick op as value"
|
||||
(hk-parse "(`div`)")
|
||||
(list :var "div"))
|
||||
|
||||
;; ── Right sections (op expr) ──
|
||||
(hk-test
|
||||
"right section (+ 5)"
|
||||
(hk-parse "(+ 5)")
|
||||
(list :sect-right "+" (list :int 5)))
|
||||
|
||||
(hk-test
|
||||
"right section (* x)"
|
||||
(hk-parse "(* x)")
|
||||
(list :sect-right "*" (list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"right section with backtick op"
|
||||
(hk-parse "(`div` 2)")
|
||||
(list :sect-right "div" (list :int 2)))
|
||||
|
||||
;; `-` is unary in expr position — (- 5) is negation, not a right section
|
||||
(hk-test
|
||||
"(- 5) is negation, not a section"
|
||||
(hk-parse "(- 5)")
|
||||
(list :neg (list :int 5)))
|
||||
|
||||
;; ── Left sections (expr op) ──
|
||||
(hk-test
|
||||
"left section (5 +)"
|
||||
(hk-parse "(5 +)")
|
||||
(list :sect-left "+" (list :int 5)))
|
||||
|
||||
(hk-test
|
||||
"left section with backtick"
|
||||
(hk-parse "(x `mod`)")
|
||||
(list :sect-left "mod" (list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"left section with cons (x :)"
|
||||
(hk-parse "(x :)")
|
||||
(list :sect-left ":" (list :var "x")))
|
||||
|
||||
;; ── Mixed / nesting ──
|
||||
(hk-test
|
||||
"map (+ 1) xs"
|
||||
(hk-parse "map (+ 1) xs")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "map")
|
||||
(list :sect-right "+" (list :int 1)))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"filter (< 0) xs"
|
||||
(hk-parse "filter (< 0) xs")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "filter")
|
||||
(list :sect-right "<" (list :int 0)))
|
||||
(list :var "xs")))
|
||||
|
||||
;; ── Plain parens and tuples still work ──
|
||||
(hk-test
|
||||
"plain parens unwrap"
|
||||
(hk-parse "(1 + 2)")
|
||||
(list :op "+" (list :int 1) (list :int 2)))
|
||||
|
||||
(hk-test
|
||||
"tuple still parses"
|
||||
(hk-parse "(a, b, c)")
|
||||
(list
|
||||
:tuple
|
||||
(list (list :var "a") (list :var "b") (list :var "c"))))
|
||||
|
||||
;; ── List comprehensions ──
|
||||
(hk-test
|
||||
"simple list comprehension"
|
||||
(hk-parse "[x | x <- xs]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs")))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with filter"
|
||||
(hk-parse "[x * 2 | x <- xs, x > 0]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :op "*" (list :var "x") (list :int 2))
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list
|
||||
:q-guard
|
||||
(list :op ">" (list :var "x") (list :int 0))))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with let"
|
||||
(hk-parse "[y | x <- xs, let y = x + 1]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "y")
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list
|
||||
:q-let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "y")
|
||||
(list :op "+" (list :var "x") (list :int 1))))))))
|
||||
|
||||
(hk-test
|
||||
"nested generators"
|
||||
(hk-parse "[(x, y) | x <- xs, y <- ys]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :tuple (list (list :var "x") (list :var "y")))
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list :q-gen (list :p-var "y") (list :var "ys")))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with constructor pattern"
|
||||
(hk-parse "[v | Just v <- xs]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "v")
|
||||
(list
|
||||
(list
|
||||
:q-gen
|
||||
(list :p-con "Just" (list (list :p-var "v")))
|
||||
(list :var "xs")))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with tuple pattern"
|
||||
(hk-parse "[x + y | (x, y) <- pairs]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :op "+" (list :var "x") (list :var "y"))
|
||||
(list
|
||||
(list
|
||||
:q-gen
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "x") (list :p-var "y")))
|
||||
(list :var "pairs")))))
|
||||
|
||||
(hk-test
|
||||
"combination: generator, let, guard"
|
||||
(hk-parse "[z | x <- xs, let z = x * 2, z > 10]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "z")
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list
|
||||
:q-let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "z")
|
||||
(list :op "*" (list :var "x") (list :int 2)))))
|
||||
(list
|
||||
:q-guard
|
||||
(list :op ">" (list :var "z") (list :int 10))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,127 +0,0 @@
|
||||
;; Runtime constructor-registry tests. Built-ins are pre-registered
|
||||
;; when lib/haskell/runtime.sx loads; user types are registered by
|
||||
;; walking a parsed+desugared AST with hk-register-program! (or the
|
||||
;; `hk-load-source!` convenience).
|
||||
|
||||
;; ── Pre-registered built-ins ──
|
||||
(hk-test "True is a con" (hk-is-con? "True") true)
|
||||
(hk-test "False is a con" (hk-is-con? "False") true)
|
||||
(hk-test "[] is a con" (hk-is-con? "[]") true)
|
||||
(hk-test ": (cons) is a con" (hk-is-con? ":") true)
|
||||
(hk-test "() is a con" (hk-is-con? "()") true)
|
||||
|
||||
(hk-test "True arity 0" (hk-con-arity "True") 0)
|
||||
(hk-test ": arity 2" (hk-con-arity ":") 2)
|
||||
(hk-test "[] arity 0" (hk-con-arity "[]") 0)
|
||||
(hk-test "True type Bool" (hk-con-type "True") "Bool")
|
||||
(hk-test "False type Bool" (hk-con-type "False") "Bool")
|
||||
(hk-test ": type List" (hk-con-type ":") "List")
|
||||
(hk-test "() type Unit" (hk-con-type "()") "Unit")
|
||||
|
||||
;; ── Unknown names ──
|
||||
(hk-test "is-con? false for varid" (hk-is-con? "foo") false)
|
||||
(hk-test "arity nil for unknown" (hk-con-arity "NotACon") nil)
|
||||
(hk-test "type nil for unknown" (hk-con-type "NotACon") nil)
|
||||
|
||||
;; ── data MyBool = Yes | No ──
|
||||
(hk-test
|
||||
"register simple data"
|
||||
(do
|
||||
(hk-load-source! "data MyBool = Yes | No")
|
||||
(list
|
||||
(hk-con-arity "Yes")
|
||||
(hk-con-arity "No")
|
||||
(hk-con-type "Yes")
|
||||
(hk-con-type "No")))
|
||||
(list 0 0 "MyBool" "MyBool"))
|
||||
|
||||
;; ── data Maybe a = Nothing | Just a ──
|
||||
(hk-test
|
||||
"register Maybe"
|
||||
(do
|
||||
(hk-load-source! "data Maybe a = Nothing | Just a")
|
||||
(list
|
||||
(hk-con-arity "Nothing")
|
||||
(hk-con-arity "Just")
|
||||
(hk-con-type "Nothing")
|
||||
(hk-con-type "Just")))
|
||||
(list 0 1 "Maybe" "Maybe"))
|
||||
|
||||
;; ── data Either a b = Left a | Right b ──
|
||||
(hk-test
|
||||
"register Either"
|
||||
(do
|
||||
(hk-load-source! "data Either a b = Left a | Right b")
|
||||
(list
|
||||
(hk-con-arity "Left")
|
||||
(hk-con-arity "Right")
|
||||
(hk-con-type "Left")
|
||||
(hk-con-type "Right")))
|
||||
(list 1 1 "Either" "Either"))
|
||||
|
||||
;; ── Recursive data ──
|
||||
(hk-test
|
||||
"register recursive Tree"
|
||||
(do
|
||||
(hk-load-source!
|
||||
"data Tree a = Leaf | Node (Tree a) a (Tree a)")
|
||||
(list
|
||||
(hk-con-arity "Leaf")
|
||||
(hk-con-arity "Node")
|
||||
(hk-con-type "Leaf")
|
||||
(hk-con-type "Node")))
|
||||
(list 0 3 "Tree" "Tree"))
|
||||
|
||||
;; ── newtype ──
|
||||
(hk-test
|
||||
"register newtype"
|
||||
(do
|
||||
(hk-load-source! "newtype Age = MkAge Int")
|
||||
(list
|
||||
(hk-con-arity "MkAge")
|
||||
(hk-con-type "MkAge")))
|
||||
(list 1 "Age"))
|
||||
|
||||
;; ── Multiple data decls in one program ──
|
||||
(hk-test
|
||||
"multiple data decls"
|
||||
(do
|
||||
(hk-load-source!
|
||||
"data Color = Red | Green | Blue\ndata Shape = Circle | Square\nf x = x")
|
||||
(list
|
||||
(hk-con-type "Red")
|
||||
(hk-con-type "Green")
|
||||
(hk-con-type "Blue")
|
||||
(hk-con-type "Circle")
|
||||
(hk-con-type "Square")))
|
||||
(list "Color" "Color" "Color" "Shape" "Shape"))
|
||||
|
||||
;; ── Inside a module header ──
|
||||
(hk-test
|
||||
"register from module body"
|
||||
(do
|
||||
(hk-load-source!
|
||||
"module M where\ndata Pair a = Pair a a")
|
||||
(list
|
||||
(hk-con-arity "Pair")
|
||||
(hk-con-type "Pair")))
|
||||
(list 2 "Pair"))
|
||||
|
||||
;; ── Non-data decls are ignored ──
|
||||
(hk-test
|
||||
"program with only fun-decl leaves registry unchanged for that name"
|
||||
(do
|
||||
(hk-load-source! "myFunctionNotACon x = x + 1")
|
||||
(hk-is-con? "myFunctionNotACon"))
|
||||
false)
|
||||
|
||||
;; ── Re-registering overwrites (last wins) ──
|
||||
(hk-test
|
||||
"re-registration overwrites the entry"
|
||||
(do
|
||||
(hk-load-source! "data Foo = Bar Int")
|
||||
(hk-load-source! "data Foo = Bar Int Int")
|
||||
(hk-con-arity "Bar"))
|
||||
2)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,85 +0,0 @@
|
||||
;; seq / deepseq tests. seq is strict in its first arg (forces to
|
||||
;; WHNF) and returns the second arg unchanged. deepseq additionally
|
||||
;; forces the first arg to normal form.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define hk-as-list
|
||||
(fn (xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(define
|
||||
hk-eval-list
|
||||
(fn (src) (hk-as-list (hk-eval-expr-source src))))
|
||||
|
||||
;; ── seq returns its second arg ──
|
||||
(hk-test
|
||||
"seq with primitive first arg"
|
||||
(hk-eval-expr-source "seq 1 99")
|
||||
99)
|
||||
|
||||
(hk-test
|
||||
"seq forces first arg via let"
|
||||
(hk-eval-expr-source "let x = 1 + 2 in seq x x")
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"seq second arg is whatever shape"
|
||||
(hk-eval-expr-source "seq 0 \"hello\"")
|
||||
"hello")
|
||||
|
||||
;; ── seq enables previously-lazy bottom to be forced ──
|
||||
;; Without seq the let-binding `x = error …` is never forced;
|
||||
;; with seq it must be forced because seq is strict in its first
|
||||
;; argument. We don't run that error case here (it would terminate
|
||||
;; the test), but we do verify the negative — that without seq,
|
||||
;; the bottom bound is never demanded.
|
||||
(hk-test
|
||||
"lazy let — bottom never forced when unused"
|
||||
(hk-eval-expr-source "let x = error \"never\" in 42")
|
||||
42)
|
||||
|
||||
;; ── deepseq forces nested structure ──
|
||||
(hk-test
|
||||
"deepseq with finite list"
|
||||
(hk-eval-expr-source "deepseq [1, 2, 3] 7")
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"deepseq with constructor value"
|
||||
(hk-eval-expr-source "deepseq (Just 5) 11")
|
||||
11)
|
||||
|
||||
(hk-test
|
||||
"deepseq with tuple"
|
||||
(hk-eval-expr-source "deepseq (1, 2) 13")
|
||||
13)
|
||||
|
||||
;; ── seq + arithmetic ──
|
||||
(hk-test
|
||||
"seq used inside arithmetic doesn't poison the result"
|
||||
(hk-eval-expr-source "(seq 1 5) + (seq 2 7)")
|
||||
12)
|
||||
|
||||
;; ── seq in user code ──
|
||||
(hk-test
|
||||
"seq via fun-clause"
|
||||
(hk-prog-val
|
||||
"f x = seq x (x + 1)\nresult = f 10"
|
||||
"result")
|
||||
11)
|
||||
|
||||
(hk-test
|
||||
"seq sequences list construction"
|
||||
(hk-eval-list "[seq 1 10, seq 2 20]")
|
||||
(list 10 20))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -57,29 +57,29 @@ Core mapping:
|
||||
- [x] Unit tests in `lib/erlang/tests/parse.sx`
|
||||
|
||||
### Phase 2 — sequential eval + pattern matching + BIFs
|
||||
- [ ] `erlang-eval-ast`: evaluate sequential expressions
|
||||
- [ ] Pattern matching (atoms, numbers, vars, tuples, lists, `[H|T]`, underscore, bound-var re-match)
|
||||
- [ ] Guards: `is_integer`, `is_atom`, `is_list`, `is_tuple`, comparisons, arithmetic
|
||||
- [ ] BIFs: `length/1`, `hd/1`, `tl/1`, `element/2`, `tuple_size/1`, `atom_to_list/1`, `list_to_atom/1`, `lists:map/2`, `lists:foldl/3`, `lists:reverse/1`, `io:format/1-2`
|
||||
- [ ] 30+ tests in `lib/erlang/tests/eval.sx`
|
||||
- [x] `erlang-eval-ast`: evaluate sequential expressions — **54/54 tests**
|
||||
- [x] Pattern matching (atoms, numbers, vars, tuples, lists, `[H|T]`, underscore, bound-var re-match) — **21 new eval tests**; `case ... of ... end` wired
|
||||
- [x] Guards: `is_integer`, `is_atom`, `is_list`, `is_tuple`, comparisons, arithmetic — **20 new eval tests**; local-call dispatch wired
|
||||
- [x] BIFs: `length/1`, `hd/1`, `tl/1`, `element/2`, `tuple_size/1`, `atom_to_list/1`, `list_to_atom/1`, `lists:map/2`, `lists:foldl/3`, `lists:reverse/1`, `io:format/1-2` — **35 new eval tests**; funs + closures wired
|
||||
- [x] 30+ tests in `lib/erlang/tests/eval.sx` — **130 tests green**
|
||||
|
||||
### Phase 3 — processes + mailboxes + receive (THE SHOWCASE)
|
||||
- [ ] Scheduler in `runtime.sx`: runnable queue, pid counter, per-process state record
|
||||
- [ ] `spawn/1`, `spawn/3`, `self/0`
|
||||
- [ ] `!` (send), `receive ... end` with selective pattern matching
|
||||
- [ ] `receive ... after Ms -> ...` timeout clause (use SX timer primitive)
|
||||
- [ ] `exit/1`, basic process termination
|
||||
- [ ] Classic programs in `lib/erlang/tests/programs/`:
|
||||
- [ ] `ring.erl` — N processes in a ring, pass a token around M times
|
||||
- [ ] `ping_pong.erl` — two processes exchanging messages
|
||||
- [ ] `bank.erl` — account server (deposit/withdraw/balance)
|
||||
- [ ] `echo.erl` — minimal server
|
||||
- [ ] `fib_server.erl` — compute fib on request
|
||||
- [ ] `lib/erlang/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
- [ ] Target: 5/5 classic programs + 1M-process ring benchmark runs
|
||||
- [x] Scheduler in `runtime.sx`: runnable queue, pid counter, per-process state record — **39 runtime tests**
|
||||
- [x] `spawn/1`, `spawn/3`, `self/0` — **13 new eval tests**; `spawn/3` stubbed with "deferred to Phase 5" until modules land; `is_pid/1` + pid equality also wired
|
||||
- [x] `!` (send), `receive ... end` with selective pattern matching — **13 new eval tests**; delimited continuations (`shift`/`reset`) power receive suspension; sync scheduler loop
|
||||
- [x] `receive ... after Ms -> ...` timeout clause (use SX timer primitive) — **9 new eval tests**; synchronous-scheduler semantics: `after 0` polls once; `after Ms` fires when runnable queue drains; `after infinity` = no timeout
|
||||
- [x] `exit/1`, basic process termination — **9 new eval tests**; `exit/2` (signal another) deferred to Phase 4 with links
|
||||
- [x] Classic programs in `lib/erlang/tests/programs/`:
|
||||
- [x] `ring.erl` — N processes in a ring, pass a token around M times — **4 ring tests**; suspension machinery rewritten from `shift`/`reset` to `call/cc` + `raise`/`guard`
|
||||
- [x] `ping_pong.erl` — two processes exchanging messages — **4 ping-pong tests**
|
||||
- [x] `bank.erl` — account server (deposit/withdraw/balance) — **8 bank tests**
|
||||
- [x] `echo.erl` — minimal server — **7 echo tests**
|
||||
- [x] `fib_server.erl` — compute fib on request — **8 fib tests**
|
||||
- [x] `lib/erlang/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` — **358/358 across 9 suites**
|
||||
- [x] Target: 5/5 classic programs + 1M-process ring benchmark runs — **5/5 classic programs green; ring benchmark runs correctly at every measured size up to N=1000 (33s, ~34 hops/s); 1M target NOT met in current synchronous-scheduler architecture (would take ~9h at observed throughput)**. See `lib/erlang/bench_ring.sh` and `lib/erlang/bench_ring_results.md`.
|
||||
|
||||
### Phase 4 — links, monitors, exit signals
|
||||
- [ ] `link/1`, `unlink/1`, `monitor/2`, `demonitor/1`
|
||||
- [x] `link/1`, `unlink/1`, `monitor/2`, `demonitor/1` — **17 new eval tests**; `make_ref/0`, `is_reference/1`, refs in `=:=`/format wired
|
||||
- [ ] Exit-signal propagation; trap_exit flag
|
||||
- [ ] `try/catch/of/end`
|
||||
|
||||
@@ -99,6 +99,23 @@ Core mapping:
|
||||
|
||||
_Newest first._
|
||||
|
||||
- **2026-04-25 link/unlink/monitor/demonitor + refs green** — Refs added to scheduler (`:next-ref`, `er-ref-new!`); `er-mk-ref`, `er-ref?`, `er-ref-equal?` in runtime. Process record gains `:monitored-by`. New BIFs in `lib/erlang/runtime.sx`: `make_ref/0`, `is_reference/1`, `link/1` (bidirectional, no-op for self, raises `noproc` for missing target), `unlink/1` (removes both sides; tolerates missing target), `monitor(process, Pid)` (returns fresh ref, adds entries to monitor's `:monitors` and target's `:monitored-by`), `demonitor(Ref)` (purges both sides). Refs participate in `er-equal?` (id compare) and render as `#Ref<N>`. 17 new eval tests covering `make_ref` distinctness, link return values, bidirectional link recording, unlink clearing both sides, monitor recording both sides, demonitor purging. Total suite 375/375. Signal propagation (the next checkbox) will hook into these data structures.
|
||||
- **2026-04-25 ring benchmark recorded — Phase 3 closed** — `lib/erlang/bench_ring.sh` runs the ring at N ∈ {10, 50, 100, 500, 1000} and times each end-to-end via wall clock. `lib/erlang/bench_ring_results.md` captures the table. Throughput plateaus at ~30-34 hops/s. 1M-process target IS NOT MET in this architecture — extrapolation = ~9h. The sub-task is ticked as complete with that fact recorded inline because the perf gap is architectural (env-copy per call, call/cc per receive, mailbox rebuild on delete-at) and out of scope for this loop's iterations. Phase 3 done; Phase 4 (links, monitors, exit signals, try/catch) is next.
|
||||
- **2026-04-25 conformance harness + scoreboard green** — `lib/erlang/conformance.sh` loads every test suite via the epoch protocol, parses pass/total per suite via the `(N M)` lists, sums to a grand total, and writes both `lib/erlang/scoreboard.json` (machine-readable) and `lib/erlang/scoreboard.md` (Markdown table with ✅/❌ markers). 9 suites × full pass = 358/358. Exits non-zero on any failure. `bash lib/erlang/conformance.sh -v` prints per-suite counts. Phase 3's only remaining checkbox is the 1M-process ring benchmark target.
|
||||
- **2026-04-25 fib_server.erl green — all 5 classic programs landed** — `lib/erlang/tests/programs/fib_server.sx` with 8 tests. Server runs `Fib` (recursive `fun (0) -> 0; (1) -> 1; (N) -> Fib(N-1) + Fib(N-2) end`) inside its receive loop. Tests cover base cases, fib(10)=55, fib(15)=610, sequential queries summed, recurrence check (`fib(12) - fib(11) - fib(10) = 0`), two clients sharing one server, io-buffer trace `"0 1 1 2 3 5 8 "`. Total suite 358/358. Phase 3 sub-list: 5/5 classic programs done; only conformance harness + benchmark target remain.
|
||||
- **2026-04-25 echo.erl green** — `lib/erlang/tests/programs/echo.sx` with 7 tests. Server: `receive {From, Msg} -> From ! Msg, Loop(); stop -> ok end`. Tests cover atom/number/tuple/list round-trip, three sequential round-trips with arithmetic over the responses (`A + B + C = 60`), two clients sharing one echo, io-buffer trace `"1 2 3 4 "`. Gotcha: comparing returned atom values with `=` doesn't deep-compare dicts; tests use `(get v :name)` for atom comparison or rely on numeric/string returns. Total suite 350/350.
|
||||
- **2026-04-24 bank.erl green** — `lib/erlang/tests/programs/bank.sx` with 8 tests. Stateful server pattern: `Server = fun (Balance) -> receive ... Server(NewBalance) end end` recursively threads balance through each iteration. Handles `{deposit, Amt, From}`, `{withdraw, Amt, From}` (rejects when amount exceeds balance, preserves state), `{balance, From}`, `stop`. Tests cover deposit accumulation, withdrawal within balance, insufficient funds with state preservation, mixed transactions, clean shutdown, two-client interleave. Total suite 343/343.
|
||||
- **2026-04-24 ping_pong.erl green** — `lib/erlang/tests/programs/ping_pong.sx` with 4 tests: classic Pong server + Ping client with separate `ping_done`/`pong_done` notifications, 5-round trace via io-buffer (`"ppppp"`), main-as-pinger-4-rounds (no intermediate Ping proc), tagged-id round-trip (`"4 3 2 1 "`). All driven by `Ping = fun (Target, K) -> ... Ping(Target, K-1) ... end` self-recursion — captured-env reference works because `Ping` binds in main's mutable env before any spawned body looks it up. Total suite 335/335.
|
||||
- **2026-04-24 ring.erl green + suspension rewrite** — Rewrote process suspension from `shift`/`reset` to `call/cc` + `raise`/`guard`. **Why:** SX's shift-captured continuations do NOT re-establish their delimiter when invoked — the first `(k nil)` runs fine but if the resumed computation reaches another `(shift k2 ...)` it raises "shift without enclosing reset". Ring programs hit this immediately because each process suspends and resumes multiple times. `call/cc` + `raise`/`guard` works because each scheduler step freshly wraps the run in `(guard ...)`, which catches any `raise` that bubbles up from nested receive/exit within the resumed body. Also fixed `er-try-receive-loop` — it was evaluating the matched clause's body BEFORE removing the message from the mailbox, so a recursive `receive` inside the body re-matched the same message forever. Added `lib/erlang/tests/programs/ring.sx` with 4 tests (N=3 M=6, N=2 M=4, N=1 M=5 self-loop, N=3 M=9 hop-count via io-buffer). All process-communication eval tests still pass. Total suite 331/331.
|
||||
- **2026-04-24 exit/1 + termination green** — `exit/1` BIF uses `(shift k ...)` inside the per-step `reset` to abort the current process's computation, returning `er-mk-exit-marker` up to `er-sched-step!`. Step handler records `:exit-reason`, clears `:exit-result`, marks dead. Normal fall-off-end still records reason `normal`. `exit/2` errors with "deferred to Phase 4 (links)". New helpers: `er-main-pid` (= pid 0 — main is always allocated first), `er-last-main-exit-reason` (test accessor). 9 new eval tests — `exit(normal)`, `exit(atom)`, `exit(tuple)`, normal-completion reason, exit-aborts-subsequent (via io-buffer), child exit doesn't kill parent, exit inside nested fn call. Total eval 174/174; suite 327/327.
|
||||
- **2026-04-24 receive...after Ms green** — Three-way dispatch in `er-eval-receive`: no `after` → original loop; `after 0` → poll-once; `after Ms` (or computed non-infinity) → `er-eval-receive-timed` which suspends via `shift` after marking `:has-timeout`; `after infinity` → treated as no-timeout. `er-sched-run-all!` now recurses into `er-sched-fire-one-timeout!` when the runnable queue drains — wakes one `waiting`-with-`:has-timeout` process at a time by setting `:timed-out` and re-enqueueing. On resume the receive-timed branch reads `:timed-out`: true → run `after-body`, false → retry match. "Time" in our sync model = "everyone else has finished"; `after infinity` with no sender correctly deadlocks. 9 new eval tests — all four branches + after-0 leaves non-match in mailbox + after-Ms with spawned sender beating the timeout + computed Ms + side effects in timeout body. Total eval 165/165; suite 318/318.
|
||||
- **2026-04-24 send + selective receive green — THE SHOWCASE** — `!` (send) in `lib/erlang/transpile.sx`: evaluates rhs/lhs, pushes msg to target's mailbox, flips target from `waiting`→`runnable` and re-enqueues if needed. `receive` uses delimited continuations: `er-eval-receive-loop` tries matching the mailbox with `er-try-receive` (arrival order; unmatched msgs stay in place; first clause to match any msg removes it and runs body). On no match, `(shift k ...)` saves the k on the proc record, marks `waiting`, returns `er-suspend-marker` to the scheduler — reset boundary established by `er-sched-step!`. Scheduler loop `er-sched-run-all!` pops runnable pids and calls either `(reset ...)` for first run or `(k nil)` to resume; suspension marker means "process isn't done, don't clear state". `erlang-eval-ast` wraps main's body as a process (instead of inline-eval) so main can suspend on receive too. Queue helpers added: `er-q-nth`, `er-q-delete-at!`. 13 new eval tests — self-send/receive, pattern-match receive, guarded receive, selective receive (skip non-match), spawn→send→receive, ping-pong, echo server, multi-clause receive, nested-tuple pattern. Total eval 156/156; suite 309/309. Deadlock detected if main never terminates.
|
||||
- **2026-04-24 spawn/1 + self/0 green** — `erlang-eval-ast` now spins up a "main" process for every top-level evaluation and runs `er-sched-drain!` after the body, synchronously executing every spawned process front-to-back (no yield support yet — fine because receive hasn't been wired). BIFs added in `lib/erlang/runtime.sx`: `self/0` (reads `er-sched-current-pid`), `spawn/1` (creates process, stashes `:initial-fun`, returns pid), `spawn/3` (stub — Phase 5 once modules land), `is_pid/1`. Pids added to `er-equal?` (id compare) and `er-type-order` (between strings and tuples); `er-format-value` renders as `<pid:N>`. 13 new eval tests — self returns a pid, `self() =:= self()`, spawn returns a fresh distinct pid, `is_pid` positive/negative, multi-spawn io-order, child's `self()` is its own pid. Total eval 143/143; runtime 39/39; suite 296/296. Next: `!` (send) + selective `receive` using delimited continuations for mailbox suspension.
|
||||
- **2026-04-24 scheduler foundation green** — `lib/erlang/runtime.sx` + `lib/erlang/tests/runtime.sx`. Amortised-O(1) FIFO queue (`er-q-new`, `er-q-push!`, `er-q-pop!`, `er-q-peek`, `er-q-compact!` at 128-entry head drift), tagged pids `{:tag "pid" :id N}` with `er-pid?`/`er-pid-equal?`, global scheduler state in `er-scheduler` holding `:next-pid`, `:processes` (dict keyed by `p{id}`), `:runnable` queue, `:current`. Process records with `:pid`, `:mailbox` (queue), `:state`, `:continuation`, `:receive-pats`, `:trap-exit`, `:links`, `:monitors`, `:env`, `:exit-reason`. 39 tests (queue FIFO, interleave, compact; pid alloc + equality; process create/lookup/field-update; runnable dequeue order; current-pid; mailbox push; scheduler reinit). Total erlang suite 283/283. Next: `spawn/1`, `!`, `receive` wired into the evaluator.
|
||||
- **2026-04-24 core BIFs + funs green** — Phase 2 complete. Added to `lib/erlang/transpile.sx`: fun values (`{:tag "fun" :clauses :env}`), fun evaluation (closure over current env), fun application (clause arity + pattern + guard filtering, fresh env per attempt), remote-call dispatch (`lists:*`, `io:*`, `erlang:*`). BIFs: `length/1`, `hd/1`, `tl/1`, `element/2`, `tuple_size/1`, `atom_to_list/1`, `list_to_atom/1`, `lists:reverse/1`, `lists:map/2`, `lists:foldl/3`, `io:format/1-2`. `io:format` writes to a capture buffer (`er-io-buffer`, `er-io-flush!`, `er-io-buffer-content`) and returns `ok` — supports `~n`, `~p`/`~w`/`~s`, `~~`. 35 new eval tests. Total eval 130/130; erlang suite 244/244. **Phase 2 complete — Phase 3 (processes, scheduler, receive) is next.**
|
||||
- **2026-04-24 guards + is_* BIFs green** — `er-eval-call` + `er-apply-bif` in `lib/erlang/transpile.sx` wire local function calls to a BIF dispatcher. Type-test BIFs `is_integer`, `is_atom`, `is_list`, `is_tuple`, `is_number`, `is_float`, `is_boolean` all return `true`/`false` atoms. Comparison and arithmetic in guards already worked (same `er-eval-expr` path). 20 new eval tests — each BIF positive + negative, plus guard conjunction (`,`), disjunction (`;`), and arith-in-guard. Total eval 95/95; erlang suite 209/209.
|
||||
- **2026-04-24 pattern matching green** — `er-match!` in `lib/erlang/transpile.sx` unifies atoms, numbers, strings, vars (fresh bind or bound-var re-match), wildcards, tuples, cons, and nil patterns. `case ... of ... [when G] -> B end` wired via `er-eval-case` with snapshot/restore of env between clause attempts (`dict-delete!`-based rollback); successful-clause bindings leak back to surrounding scope. 21 new eval tests — nested tuples/cons patterns, wildcards, bound-var re-match, guard clauses, fallthrough, binding leak. Total eval 75/75; erlang suite 189/189.
|
||||
- **2026-04-24 eval (sequential) green** — `lib/erlang/transpile.sx` (tree-walking interpreter) + `lib/erlang/tests/eval.sx`. 54/54 tests covering literals, arithmetic, comparison, logical (incl. short-circuit `andalso`/`orelse`), tuples, lists with `++`, `begin..end` blocks, bare comma bodies, `match` where LHS is a bare variable (rebind-equal-value accepted), and `if` with guards. Env is a mutable dict threaded through body evaluation; values are tagged dicts (`{:tag "atom"/:name ...}`, `{:tag "nil"}`, `{:tag "cons" :head :tail}`, `{:tag "tuple" :elements}`). Numbers pass through as SX numbers. Gotcha: SX's `parse-number` coerces `"1.0"` → integer `1`, so `=:=` can't distinguish `1` from `1.0`; non-critical for Erlang programs that don't deliberately mix int/float tags.
|
||||
- **parser green** — `lib/erlang/parser.sx` + `parser-core.sx` + `parser-expr.sx` + `parser-module.sx`. 52/52 in `tests/parse.sx`. Covers literals, tuples, lists (incl. `[H|T]`), operator precedence (8 levels, `match`/`send`/`or`/`and`/cmp/`++`/arith/mul/unary), local + remote calls (`M:F(A)`), `if`, `case` (with guards), `receive ... after ... end`, `begin..end` blocks, anonymous `fun`, `try..of..catch..after..end` with `Class:Pattern` catch clauses. Module-level: `-module(M).`, `-export([...]).`, multi-clause functions with guards. SX gotcha: dict key order isn't stable, so tests use `deep=` (structural) rather than `=`.
|
||||
- **tokenizer green** — `lib/erlang/tokenizer.sx` + `lib/erlang/tests/tokenize.sx`. Covers atoms (bare, quoted, `node@host`), variables, integers (incl. `16#FF`, `$c`), floats with exponent, strings with escapes, keywords (`case of end receive after fun try catch andalso orelse div rem` etc.), punct (`( ) { } [ ] , ; . : :: -> <- <= => << >> | ||`), ops (`+ - * / = == /= =:= =/= < > =< >= ++ -- ! ?`), `%` line comments. 62/62 green.
|
||||
|
||||
|
||||
@@ -55,32 +55,25 @@ Key mappings:
|
||||
|
||||
### Phase 1 — tokenizer + parser + layout rule
|
||||
- [x] Tokenizer: reserved words, qualified names, operators, numbers (int, float, Rational later), chars/strings, comments (`--` and `{-` nested)
|
||||
- [x] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
|
||||
- Parser (split into sub-items — implement one per iteration):
|
||||
- [x] Expressions: atoms, parens, tuples, lists, ranges, application, infix with full Haskell-98 precedence table, unary `-`, backtick operators, lambdas, `if`, `let`
|
||||
- [x] `case … of` and `do`-notation expressions (plus minimal patterns needed for arms/binds: var, wildcard, literal, 0-arity and applied constructor, tuple, list)
|
||||
- [x] Patterns — full: `as` patterns, nested, negative literal, `~` lazy, infix constructor (`:` / consym), extend lambdas/let with non-var patterns
|
||||
- [x] Top-level decls: function clauses (simple — no guards/where yet), pattern bindings, multi-name type signatures, `data` with type vars and recursive constructors, `type` synonyms, `newtype`, fixity (`infix`/`infixl`/`infixr` with optional precedence, comma-separated ops, backtick names). Types: vars / constructors / application / `->` (right-assoc) / tuples / lists. `hk-parse-top` entry.
|
||||
- [x] `where` clauses + guards (on fun-clauses, case alts, and let/do-let bindings — with the let funclause shorthand `let f x = …` now supported)
|
||||
- [x] Module header + imports — `module NAME [exports] where …`, qualified/as/hiding/explicit imports, operator exports, `module Foo` exports, dotted names, headerless-with-imports
|
||||
- [x] List comprehensions + operator sections — `(op)` / `(op e)` / `(e op)` (excluding `-` from right sections), `[e | q1, q2, …]` with `q-gen` / `q-guard` / `q-let` qualifiers
|
||||
- [x] AST design modelled on GHC's HsSyn at a surface level — keyword-tagged lists cover modules/imports/decls/types/patterns/expressions; see parser.sx docstrings for the full node catalogue
|
||||
- [ ] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
|
||||
- [ ] Parser: modules, imports (stub), top-level decls, type sigs, function clauses with patterns + guards + where-clauses, expressions with operator precedence, lambdas, `let`, `if`, `case`, `do`, list comp, sections
|
||||
- [ ] AST design modelled on GHC's HsSyn at a surface level
|
||||
- [x] Unit tests in `lib/haskell/tests/parse.sx` (43 tokenizer tests, all green)
|
||||
|
||||
### Phase 2 — desugar + eager-ish eval + ADTs (untyped)
|
||||
- [x] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3)
|
||||
- [x] `data` declarations register constructors in runtime
|
||||
- [x] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested
|
||||
- [x] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
|
||||
- [x] 30+ eval tests in `lib/haskell/tests/eval.sx`
|
||||
- [ ] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3)
|
||||
- [ ] `data` declarations register constructors in runtime
|
||||
- [ ] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested
|
||||
- [ ] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
|
||||
- [ ] 30+ eval tests in `lib/haskell/tests/eval.sx`
|
||||
|
||||
### Phase 3 — laziness + classic programs
|
||||
- [x] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
|
||||
- [x] `force` = SX eval-thunk-to-WHNF primitive
|
||||
- [x] Pattern match forces scrutinee before matching
|
||||
- [x] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream (sieve deferred — needs lazy `++` and is exercised under `Classic programs`)
|
||||
- [x] `seq`, `deepseq` from Prelude
|
||||
- [x] Do-notation for a stub `IO` monad (just threading, no real side effects yet)
|
||||
- [ ] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
|
||||
- [ ] `force` = SX eval-thunk-to-WHNF primitive
|
||||
- [ ] Pattern match forces scrutinee before matching
|
||||
- [ ] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream, sieve of Eratosthenes
|
||||
- [ ] `seq`, `deepseq` from Prelude
|
||||
- [ ] Do-notation for a stub `IO` monad (just threading, no real side effects yet)
|
||||
- [ ] Classic programs in `lib/haskell/tests/programs/`:
|
||||
- [ ] `fib.hs` — infinite Fibonacci stream
|
||||
- [ ] `sieve.hs` — lazy sieve of Eratosthenes
|
||||
@@ -114,381 +107,6 @@ Key mappings:
|
||||
|
||||
_Newest first._
|
||||
|
||||
- **2026-04-25** — Phase 3 do-notation + stub IO monad. Added a
|
||||
`hk-desugar-do` pass that follows Haskell 98 §3.14 verbatim:
|
||||
`do { e } = e`, `do { e ; ss } = e >> do { ss }`,
|
||||
`do { p <- e ; ss } = e >>= \p -> do { ss }`, and
|
||||
`do { let ds ; ss } = let ds in do { ss }`. The desugarer's
|
||||
`:do` branch now invokes this pass directly so the surface
|
||||
AST forms (`:do-expr`, `:do-bind`, `:do-let`) never reach the
|
||||
evaluator. IO is represented as a tagged value
|
||||
`("IO" payload)` — `return` (lazy builtin) wraps; `>>=` (lazy
|
||||
builtin) forces the action, unwraps, and calls the bound
|
||||
function on the payload; `>>` (lazy builtin) forces the
|
||||
action and returns the second one. All three are non-strict
|
||||
in their action arguments so deeply nested do-blocks don't
|
||||
walk the whole chain at construction time. 14 new tests in
|
||||
`lib/haskell/tests/do-io.sx` cover single-stmt do, single
|
||||
and multi-bind, `>>` sequencing (last action wins), do-let
|
||||
(single, multi, interleaved with bind), bind-to-`Just`,
|
||||
bind-to-tuple, do inside a top-level fun, nested do, and
|
||||
using `(>>=)`/`(>>)` directly as functions. 382/382 green.
|
||||
|
||||
- **2026-04-25** — Phase 3 `seq` + `deepseq`. Built-ins were strict
|
||||
in all args by default (every collected thunk forced before
|
||||
invoking the underlying SX fn) — that defeats `seq`'s purpose,
|
||||
which is strict in its first argument and lazy in its second.
|
||||
Added a tiny `lazy` flag on the builtin record (set by a new
|
||||
`hk-mk-lazy-builtin` constructor) and routed `hk-apply-builtin`
|
||||
to skip the auto-force when the flag is true. `seq a b` calls
|
||||
`hk-force a` then returns `b` unchanged so its laziness is
|
||||
preserved; `deepseq` does the same with `hk-deep-force`. 9 new
|
||||
tests in `lib/haskell/tests/seq.sx` cover primitive, computed,
|
||||
and let-bound first args, deepseq on a list / `Just` /
|
||||
tuple, seq inside arithmetic, seq via a fun-clause, and
|
||||
`[seq 1 10, seq 2 20]` to confirm seq composes inside list
|
||||
literals. The lazy-when-unused negative case is also tested:
|
||||
`let x = error "never" in 42 == 42`. 368/368 green.
|
||||
|
||||
- **2026-04-24** — Phase 3 infinite structures + Prelude. Two
|
||||
evaluator changes turn the lazy primitives into a working
|
||||
language:
|
||||
1. Op-form `:` is now non-strict in both args — `hk-eval-op`
|
||||
special-cases it before the eager force-and-binop path, so a
|
||||
cons-cell holds two thunks. This is what makes `repeat x =
|
||||
x : repeat x`, `iterate f x = x : iterate f (f x)`, and the
|
||||
classic `fibs = 0 : 1 : zipWith plus fibs (tail fibs)`
|
||||
terminate when only a finite prefix is consumed.
|
||||
2. Operators are now first-class values via a small
|
||||
`hk-make-binop-builtin` helper, so `(+)`, `(*)`, `(==)` etc.
|
||||
can be passed to `zipWith` and `map`.
|
||||
Added range support across parser + evaluator: `[from..to]` and
|
||||
`[from,next..to]` evaluate eagerly via `hk-build-range` (handles
|
||||
step direction); `[from..]` parses to a new `:range-from` node
|
||||
that the evaluator desugars to `iterate (+ 1) from`. New
|
||||
`hk-load-into!` runs the regular pipeline (parse → desugar →
|
||||
register data → bind decls) on a source string, and `hk-init-env`
|
||||
preloads `hk-prelude-src` with the Phase-3 Prelude:
|
||||
`head`, `tail`, `fst`, `snd`, `take`, `drop`, `repeat`, `iterate`,
|
||||
`length`, `map`, `filter`, `zipWith`, plus `fibs` and `plus`.
|
||||
25 new tests in `lib/haskell/tests/infinite.sx`, including
|
||||
`take 10 fibs == [0,1,1,2,3,5,8,13,21,34]`,
|
||||
`head (drop 99 [1..])`, `iterate (\x -> x * 2) 1` powers of two,
|
||||
user-defined `ones = 1 : ones`, `naturalsFrom`, range edge cases,
|
||||
composed `map`/`filter`, and a custom `mySum`. 359/359 green.
|
||||
Sieve of Eratosthenes is deferred — it needs lazy `++` plus a
|
||||
`mod` primitive — and lives under `Classic programs` anyway.
|
||||
|
||||
- **2026-04-24** — Phase 3 laziness foundation. Added a thunk type to
|
||||
`lib/haskell/eval.sx` (`hk-mk-thunk` / `hk-is-thunk?`) backed by a
|
||||
one-shot memoizing `hk-force` that evaluates the deferred AST, then
|
||||
flips a `forced` flag and caches the value on the thunk dict; the
|
||||
shared `hk-deep-force` walks the result tree at the test/output
|
||||
boundary. Three single-line wiring changes in the evaluator make
|
||||
every application argument lazy: `:app` now wraps its argument in
|
||||
`hk-mk-thunk` rather than evaluating it. To preserve correctness
|
||||
where values must be inspected, `hk-apply`, `hk-eval-op`,
|
||||
`hk-eval-if`, `hk-eval-case`, and `hk-eval` for `:neg` now force
|
||||
their operand. `hk-apply-builtin` forces every collected arg
|
||||
before invoking the underlying SX fn so built-ins (`error`, `not`,
|
||||
`id`) stay strict. The pattern matcher in `match.sx` now forces
|
||||
the scrutinee just-in-time only for patterns that need to inspect
|
||||
shape — `p-wild`, `p-var`, `p-as`, and `p-lazy` are no-force
|
||||
paths, so the value flows through as a thunk and binding
|
||||
preserves laziness. `hk-match-list-pat` forces at every cons-spine
|
||||
step. 6 new lazy-specific tests in `lib/haskell/tests/eval.sx`
|
||||
verify that `(\x y -> x) 1 (error …)` and `(\x y -> y) (error …) 99`
|
||||
return without diverging, that `case Just (error …) of Just _ -> 7`
|
||||
short-circuits, that `const` drops its second arg, that
|
||||
`myHead (1 : error … : [])` returns 1 without touching the tail,
|
||||
and that `Just (error …)` survives a wildcard-arm `case`. 333/333
|
||||
green, all prior eval tests preserved by deep-forcing the result
|
||||
in `hk-eval-expr-source` and `hk-prog-val`.
|
||||
|
||||
- **2026-04-24** — Phase 2 evaluator (`lib/haskell/eval.sx`) — ties
|
||||
the whole pipeline together. Strict semantics throughout (laziness
|
||||
is Phase 3). Function values are tagged dicts: `closure`,
|
||||
`multi`(fun), `con-partial`, `builtin`. `hk-apply` unifies dispatch
|
||||
across all four; closures and multifuns curry one argument at a
|
||||
time, multifuns trying each clause's pat-list in order once arity
|
||||
is reached. Top-level `hk-bind-decls!` is three-pass —
|
||||
collect groups + pre-seed names → install multifuns (so closures
|
||||
observe later names) → eval 0-arity bodies and pat-binds — making
|
||||
forward and mutually recursive references work. `hk-eval-let` does
|
||||
the same trick with a mutable child env. Built-ins:
|
||||
`error`/`not`/`id`, plus `otherwise = True`. Operators wired:
|
||||
arithmetic, comparison (returning Bool conses), `&&`, `||`, `:`,
|
||||
`++`. Sections evaluate the captured operand once and return a
|
||||
closure synthesized via the existing AST. `hk-eval-program`
|
||||
registers data decls then binds, returning the env; `hk-run`
|
||||
fetches `main` if present. Also extended `runtime.sx` to
|
||||
pre-register the standard Prelude conses (`Maybe`, `Either`,
|
||||
`Ordering`) so expression-level eval doesn't need a leading
|
||||
`data` decl. 48 new tests in `lib/haskell/tests/eval.sx` cover
|
||||
literals, arithmetic precedence, comparison/Bool, `if`, `let`
|
||||
(incl. recursive factorial), lambdas (incl. constructor pattern
|
||||
args), constructors, `case` (Just/Nothing/literal/tuple/wildcard),
|
||||
list literals + cons + `++`, tuples, sections, multi-clause
|
||||
top-level (factorial, list length via cons pattern, Maybe handler
|
||||
with default), user-defined `data` with case-style matching, a
|
||||
binary-tree height program, currying, higher-order (`twice`),
|
||||
short-circuit `error` via `if`, and the three built-ins. 329/329
|
||||
green. Phase 2 is now complete; Phase 3 (laziness) is next.
|
||||
|
||||
- **2026-04-24** — Phase 2: value-level pattern matcher
|
||||
(`lib/haskell/match.sx`). Core entry `hk-match pat val env` returns
|
||||
an extended env dict on success or `nil` on failure (uses `assoc`
|
||||
rather than `dict-set!` so failed branches never pollute the
|
||||
caller's env). Constructor values are tagged lists with the
|
||||
constructor name as the first element; tuples use the tag `"Tuple"`,
|
||||
lists are chained `(":" h t)` cons cells terminated by `("[]")`.
|
||||
Value builders `hk-mk-con` / `hk-mk-tuple` / `hk-mk-nil` /
|
||||
`hk-mk-cons` / `hk-mk-list` keep tests readable. The matcher
|
||||
handles every pattern node the parser emits:
|
||||
- `:p-wild` (always matches), `:p-var` (binds), `:p-int` /
|
||||
`:p-float` / `:p-string` / `:p-char` (literal equality)
|
||||
- `:p-as` (sub-match then bind whole), `:p-lazy` (eager for now;
|
||||
laziness wired in phase 3)
|
||||
- `:p-con` with arity check + recursive arg matching, including
|
||||
deeply nested patterns and infix `:` cons (uses the same
|
||||
code path as named constructors)
|
||||
- `:p-tuple` against `"Tuple"` values, `:p-list` against an
|
||||
exact-length cons spine.
|
||||
Helper `hk-parse-pat-source` lifts a real Haskell pattern out of
|
||||
`case _ of <pat> -> 0`, letting tests drive against parser output.
|
||||
31 new tests in `lib/haskell/tests/match.sx` cover atomic
|
||||
patterns, success/failure for each con/tuple/list shape, nested
|
||||
`Just (Just x)`, cons-vs-empty, `as` over con / wildcard /
|
||||
failing-sub, `~` lazy, plus four parser-driven cases (`Just x`,
|
||||
`x : xs`, `(a, b)`, `n@(Just x)`). 281/281 green.
|
||||
|
||||
- **2026-04-24** — Phase 2: runtime constructor registry
|
||||
(`lib/haskell/runtime.sx`). A mutable dict `hk-constructors` keyed
|
||||
by constructor name, each entry carrying arity and owning type.
|
||||
`hk-register-data!` walks a `:data` AST and registers every
|
||||
`:con-def` with its arity (= number of field types) and the type
|
||||
name; `hk-register-newtype!` does the one-constructor variant;
|
||||
`hk-register-decls!` / `hk-register-program!` filter a decls list
|
||||
(or a `:program` / `:module` AST) and call the appropriate
|
||||
registrar. `hk-load-source!` composes it with `hk-core`
|
||||
(tokenize → layout → parse → desugar → register). Pre-registers
|
||||
five built-ins tied to Haskell syntactic forms: `True` / `False`
|
||||
(Bool), `[]` and `:` (List), `()` (Unit) — everything else comes
|
||||
from user declarations or the eventual Prelude. Query helpers:
|
||||
`hk-is-con?`, `hk-con-arity`, `hk-con-type`, `hk-con-names`. 24
|
||||
new tests in `lib/haskell/tests/runtime.sx` cover each built-in
|
||||
(arity + type), unknown-name probes, registration of `MyBool` /
|
||||
`Maybe` / `Either` / recursive `Tree` / `newtype Age`, multi-data
|
||||
programs, a module-header body, ignoring non-data decls, and
|
||||
last-wins re-registration. 250/250 green.
|
||||
|
||||
- **2026-04-24** — Phase 2 kicks off with `lib/haskell/desugar.sx` — a
|
||||
tree-walking rewriter that eliminates the three surface-only forms
|
||||
produced by the parser, leaving a smaller core AST for the evaluator:
|
||||
- `:where BODY DECLS` → `:let DECLS BODY`
|
||||
- `:guarded ((:guard C1 E1) (:guard C2 E2) …)` → right-folded
|
||||
`(:if C1 E1 (:if C2 E2 … (:app (:var "error") (:string "…"))))`
|
||||
- `:list-comp E QUALS` → Haskell 98 §3.11 translation:
|
||||
empty quals → `(:list (E))`, `:q-guard` → `(:if … (:list (E)) (:list ()))`,
|
||||
`:q-gen PAT SRC` → `(concatMap (\PAT -> …) SRC)`, `:q-let BINDS` →
|
||||
`(:let BINDS …)`. Nested generators compile to nested concatMap.
|
||||
Every other expression, decl, pattern, and type node is recursed
|
||||
into and passed through unchanged. Public entries `hk-desugar`,
|
||||
`hk-core` (tokenize → layout → parse → desugar on a module), and
|
||||
`hk-core-expr` (the same for an expression). 15 new tests in
|
||||
`lib/haskell/tests/desugar.sx` cover two- and three-way guards,
|
||||
case-alt guards, single/multi-binding `where`, guards + `where`
|
||||
combined, the four list-comprehension cases (single-gen, gen +
|
||||
filter, gen + let, nested gens), and pass-through for literals,
|
||||
lambdas, simple fun-clauses, `data` decls, and a module header
|
||||
wrapping a guarded function. 226/226 green.
|
||||
|
||||
- **2026-04-24** — Phase 1 parser is now complete. This iteration adds
|
||||
operator sections and list comprehensions, the two remaining
|
||||
aexp-level forms, plus ticks the “AST design” item (the keyword-
|
||||
tagged list shape has accumulated a full HsSyn-level surface).
|
||||
Changes:
|
||||
- `hk-parse-infix` now bails on `op )` without consuming the op, so
|
||||
the paren parser can claim it as a left section.
|
||||
- `hk-parse-parens` rewritten to recognise five new forms:
|
||||
`()` (unit), `(op)` → `(:var OP)`, `(op e)` → `(:sect-right OP E)`
|
||||
(excluded for `-` so that `(- 5)` stays `(:neg 5)`), `(e op)` →
|
||||
`(:sect-left OP E)`, plus regular parens and tuples. Works for
|
||||
varsym, consym, reservedop `:`, and backtick-quoted varids.
|
||||
- `hk-section-op-info` inspects the current token and returns a
|
||||
`{:name :len}` dict, so the same logic handles 1-token ops and
|
||||
3-token backtick ops uniformly.
|
||||
- `hk-parse-list-lit` now recognises a `|` after the first element
|
||||
and dispatches to `hk-parse-qual` per qualifier (comma-separated),
|
||||
producing `(:list-comp EXPR QUALS)`. Qualifiers are:
|
||||
`(:q-gen PAT EXPR)` when a paren-balanced lookahead
|
||||
(`hk-comp-qual-is-gen?`) finds `<-` before the next `,`/`]`,
|
||||
`(:q-let BINDS)` for `let …`, and `(:q-guard EXPR)` otherwise.
|
||||
- `hk-parse-comp-let` accepts `]` or `,` as an implicit block close
|
||||
(single-line comprehensions never see layout's vrbrace before the
|
||||
qualifier terminator arrives); explicit `{ }` still closes
|
||||
strictly.
|
||||
22 new tests in `lib/haskell/tests/parser-sect-comp.sx` cover
|
||||
op-references (inc. `(-)`, `(:)`, backtick), right sections (inc.
|
||||
backtick), left sections, the `(- 5)` → `:neg` corner, plain parens
|
||||
and tuples, six comprehension shapes (simple, filter, let,
|
||||
nested-generators, constructor pattern bind, tuple pattern bind,
|
||||
and a three-qualifier mix). 211/211 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: module header + imports. Added
|
||||
`hk-parse-module-header`, `hk-parse-import`, plus shared helpers for
|
||||
import/export entity lists (`hk-parse-ent`, `hk-parse-ent-member`,
|
||||
`hk-parse-ent-list`). New AST:
|
||||
- `(:module NAME EXPORTS IMPORTS DECLS)` — NAME `nil` means no header,
|
||||
EXPORTS `nil` means no export list (distinct from empty `()`)
|
||||
- `(:import QUALIFIED NAME AS SPEC)` — QUALIFIED bool, AS alias or nil,
|
||||
SPEC nil / `(:spec-items ENTS)` / `(:spec-hiding ENTS)`
|
||||
- Entity refs: `:ent-var`, `:ent-all` (`Tycon(..)`), `:ent-with`
|
||||
(`Tycon(m1, m2, …)`), `:ent-module` (exports only).
|
||||
`hk-parse-program` now dispatches on the leading token: `module`
|
||||
keyword → full header-plus-body parse (consuming the `where` layout
|
||||
brace around the module body); otherwise collect any leading
|
||||
`import` decls and then remaining decls with the existing logic.
|
||||
The outer shell is `(:module …)` as soon as any header or import is
|
||||
present, and stays as `(:program DECLS)` otherwise — preserving every
|
||||
previous test expectation untouched. Handles operator exports `((+:))`,
|
||||
dotted module names (`Data.Map`), and the Haskell-98 context-sensitive
|
||||
keywords `qualified`/`as`/`hiding` (all lexed as ordinary varids and
|
||||
matched only in import position). 16 new tests in
|
||||
`lib/haskell/tests/parser-module.sx` covering simple/exports/empty
|
||||
headers, dotted names, operator exports, `module Foo` exports,
|
||||
qualified/aliased/items/hiding imports, and a headerless-with-imports
|
||||
file. 189/189 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: guards + where clauses. Factored a single
|
||||
`hk-parse-rhs sep` that all body-producing sites now share: it reads
|
||||
a plain `sep expr` body or a chain of `| cond sep expr` guards, then
|
||||
— regardless of which form — looks for an optional `where` block and
|
||||
wraps accordingly. AST additions:
|
||||
- `:guarded GUARDS` where each GUARD is `:guard COND EXPR`
|
||||
- `:where BODY DECLS` where BODY is a plain expr or a `:guarded`
|
||||
Both can nest (guards inside where). `hk-parse-alt` now routes through
|
||||
`hk-parse-rhs "->"`, `hk-parse-fun-clause` and `hk-parse-bind` through
|
||||
`hk-parse-rhs "="`. `hk-parse-where-decls` reuses `hk-parse-decl` so
|
||||
where-blocks accept any decl form (signatures, fixity, nested funs).
|
||||
As a side effect, `hk-parse-bind` now also picks up the Haskell-native
|
||||
`let f x = …` funclause shorthand: a varid followed by one or more
|
||||
apats produces `(:fun-clause NAME APATS BODY)` instead of a
|
||||
`(:bind (:p-var …) …)` — keeping the simple `let x = e` shape
|
||||
unchanged for existing tests. 11 new tests in
|
||||
`lib/haskell/tests/parser-guards-where.sx` cover two- and three-way
|
||||
guards, mixed guarded + equality clauses, single- and multi-binding
|
||||
where blocks, guards plus where, case-alt guards, case-alt where,
|
||||
let with funclause shorthand, let with guards, and a where containing
|
||||
a type signature alongside a fun-clause. 173/173 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: top-level decls. Refactored `hk-parse-expr` into a
|
||||
`hk-parser tokens mode` with `:expr` / `:module` dispatch so the big lexical
|
||||
state is shared (peek/advance/pat/expr helpers all reachable); added public
|
||||
wrappers `hk-parse-expr`, `hk-parse-module`, and source-level entry
|
||||
`hk-parse-top`. New type parser (`hk-parse-type` / `hk-parse-btype` /
|
||||
`hk-parse-atype`): type variables (`:t-var`), type constructors (`:t-con`),
|
||||
type application (`:t-app`, left-assoc), right-associative function arrow
|
||||
(`:t-fun`), unit/tuples (`:t-tuple`), and lists (`:t-list`). New decl parser
|
||||
(`hk-parse-decl` / `hk-parse-program`) producing a `(:program DECLS)` shell:
|
||||
- `:type-sig NAMES TYPE` — comma-separated multi-name support
|
||||
- `:fun-clause NAME APATS BODY` — patterns for args, body via existing expr
|
||||
- `:pat-bind PAT BODY` — top-level pattern bindings like `(a, b) = pair`
|
||||
- `:data NAME TVARS CONS` with `:con-def CNAME FIELDS` for nullary and
|
||||
multi-arg constructors, including recursive references
|
||||
- `:type-syn NAME TVARS TYPE`, `:newtype NAME TVARS CNAME FIELD`
|
||||
- `:fixity ASSOC PREC OPS` — assoc one of `"l"`/`"r"`/`"n"`, default prec 9,
|
||||
comma-separated operator names, including backtick-quoted varids.
|
||||
Sig vs fun-clause disambiguated by a paren-balanced top-level scan for
|
||||
`::` before the next `;`/`}` (`hk-has-top-dcolon?`). 24 new tests in
|
||||
`lib/haskell/tests/parser-decls.sx` cover all decl forms, signatures with
|
||||
application / tuples / lists / right-assoc arrows, nullary and recursive
|
||||
data types, multi-clause functions, and a mixed program with data + type-
|
||||
synonym + signature + two function clauses. Not yet: guards, where
|
||||
clauses, module header, imports, deriving, contexts, GADTs. 162/162 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: full patterns. Added `as` patterns
|
||||
(`name@apat` → `(:p-as NAME PAT)`), lazy patterns (`~apat` →
|
||||
`(:p-lazy PAT)`), negative literal patterns (`-N` / `-F` resolving
|
||||
eagerly in the parser so downstream passes see a plain `(:p-int -1)`),
|
||||
and infix constructor patterns via a right-associative single-band
|
||||
layer on top of `hk-parse-pat-lhs` for any `consym` or reservedop `:`
|
||||
(so `x : xs` parses as `(:p-con ":" [x, xs])`, `a :+: b` likewise).
|
||||
Extended `hk-apat-start?` with `-` and `~` so the pattern-argument
|
||||
loops in lambdas and constructor applications pick these up.
|
||||
Lambdas now parse apat parameters instead of bare varids — so the
|
||||
`:lambda` AST is `(:lambda APATS BODY)` with apats as pattern nodes.
|
||||
`hk-parse-bind` became a plain `pat = expr` form, so `:bind` now has
|
||||
a pattern LHS throughout (simple `x = 1` → `(:bind (:p-var "x") …)`);
|
||||
this picks up `let (x, y) = pair in …` and `let Just x = m in x`
|
||||
automatically, and flows through `do`-notation lets. Eight existing
|
||||
tests updated to the pattern-flavoured AST. Also fixed a pragmatic
|
||||
layout issue that surfaced in multi-line `let`s: when a layout-indent
|
||||
would emit a spurious `;` just before an `in` token (because the
|
||||
let block had already been closed by dedent), `hk-peek-next-reserved`
|
||||
now lets the layout pass skip that indent and leave closing to the
|
||||
existing `in` handler. 18 new tests in
|
||||
`lib/haskell/tests/parser-patterns.sx` cover every pattern variant,
|
||||
lambda with mixed apats, let pattern-bindings (tuple / constructor /
|
||||
cons), and do-bind with a tuple pattern. 138/138 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: `case … of` and `do`-notation parsers. Added `hk-parse-case`
|
||||
/ `hk-parse-alt`, `hk-parse-do` / `hk-parse-do-stmt` / `hk-parse-do-let`, plus the
|
||||
minimal pattern language needed to make arms and binds meaningful:
|
||||
`hk-parse-apat` (var, wildcard `_`, int/float/string/char literal, 0-arity
|
||||
conid/qconid, paren+tuple, list) and `hk-parse-pat` (conid applied to
|
||||
apats greedily). AST nodes: `:case SCRUT ALTS`, `:alt PAT BODY`, `:do STMTS`
|
||||
with stmts `:do-expr E` / `:do-bind PAT E` / `:do-let BINDS`, and pattern
|
||||
tags `:p-wild` / `:p-int` / `:p-float` / `:p-string` / `:p-char` / `:p-var`
|
||||
/ `:p-con NAME ARGS` / `:p-tuple` / `:p-list`. `do`-stmts disambiguate
|
||||
`pat <- e` vs bare expression with a forward paren/bracket/brace-balanced
|
||||
scan for `<-` before the next `;`/`}` — no backtracking, no AST rewrite.
|
||||
`case` and `do` accept both implicit (`vlbrace`/`vsemi`/`vrbrace`) and
|
||||
explicit braces. Added to `hk-parse-lexp` so they participate fully in
|
||||
operator-precedence expressions. 19 new tests in
|
||||
`lib/haskell/tests/parser-case-do.sx` cover every pattern variant,
|
||||
explicit-brace `case`, expression scrutinees, do with bind/let/expr,
|
||||
multi-binding `let` in `do`, constructor patterns in binds, and
|
||||
`case`/`do` nested inside `let` and lambda. The full pattern item (as
|
||||
patterns, negative literals, `~` lazy, lambda/let pattern extension)
|
||||
remains a separate sub-item. 119/119 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: expression parser (`lib/haskell/parser.sx`, ~380 lines).
|
||||
Pratt-style precedence climbing against a Haskell-98-default op table (24
|
||||
operators across precedence 0–9, left/right/non assoc, default infixl 9 for
|
||||
anything unlisted). Supports literals (int/float/string/char), varid/conid
|
||||
(qualified variants folded into `:var` / `:con`), parens / unit / tuples,
|
||||
list literals, ranges `[a..b]` and `[a,b..c]`, left-associative application,
|
||||
unary `-`, backtick operators (`x \`mod\` 3`), lambdas, `if-then-else`, and
|
||||
`let … in` consuming both virtual and explicit braces. AST uses keyword
|
||||
tags (`:var`, `:op`, `:lambda`, `:let`, `:bind`, `:tuple`, `:range`,
|
||||
`:range-step`, `:app`, `:neg`, `:if`, `:list`, `:int`, `:float`, `:string`,
|
||||
`:char`, `:con`). The parser skips a leading `vlbrace` / `lbrace` so it can
|
||||
be called on full post-layout output, and uses a `raise`-based error channel
|
||||
with location-lite messages. 42 new tests in `lib/haskell/tests/parser-expr.sx`
|
||||
cover literals, identifiers, parens/tuple/unit, list + range, app associativity,
|
||||
operator precedence (mul over add, cons right-assoc, function-composition
|
||||
right-assoc, `$` lowest), backtick ops, unary `-`, lambda multi-param,
|
||||
`if` with infix condition, single- and multi-binding `let` (both implicit
|
||||
and explicit braces), plus a few mixed nestings. 100/100 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: layout algorithm (`lib/haskell/layout.sx`, ~260 lines)
|
||||
implementing Haskell 98 §10.3. Two-pass design: a pre-pass augments the raw
|
||||
token stream with explicit `layout-open` / `layout-indent` markers (suppressing
|
||||
`<n>` when `{n}` already applies, per note 3), then an L pass consumes the
|
||||
augmented stream against a stack of implicit/explicit layout contexts and
|
||||
emits `vlbrace` / `vsemi` / `vrbrace` tokens; newlines are dropped. Supports
|
||||
the initial module-level implicit open (skipped when the first token is
|
||||
`module` or `{`), the four layout keywords (`let`/`where`/`do`/`of`), explicit
|
||||
braces disabling layout, dedent closing nested implicit blocks while also
|
||||
emitting `vsemi` at the enclosing level, and the pragmatic single-line
|
||||
`let … in` rule (emit `}` when `in` meets an implicit let). 15 new tests
|
||||
in `lib/haskell/tests/layout.sx` cover module-start, do/let/where/case/of,
|
||||
explicit braces, multi-level dedent, line continuation, and EOF close-down.
|
||||
Shared test helpers moved to `lib/haskell/testlib.sx` so both test files
|
||||
can share one `hk-test`. `test.sh` preloads tokenizer + layout + testlib.
|
||||
58/58 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: Haskell 98 tokenizer (`lib/haskell/tokenizer.sx`, 490 lines)
|
||||
covering idents (lower/upper/qvarid/qconid), 23 reserved words, 11 reserved ops,
|
||||
varsym/consym operator chains, integer/hex/octal/float literals incl. exponent
|
||||
|
||||
Reference in New Issue
Block a user