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

merge: architecture into bugs/jit-perf — Phase 1 deadline tweaks

Browse Source 
Conflict in lib/tcl/test.sh: architecture had bumped `timeout 2400 → 7200`,
this branch had restored it to `timeout 300` based on the Phase 1
quiet-machine measurement (376/376 in 57.8s wall, 16.3s user). Resolved by
keeping `timeout 300` — the 7200s bump was preemptive against contention,
not against an actual substrate regression. Phase 1 confirms the original
180s deadline is comfortable; 300s gives 5× headroom for moderate noise.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-08 14:07:14 +00:00
parent c361946974 62da10030b
commit 92f6f187b7
57 changed files with 6289 additions and 595 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
lib/apl/parser.sx
View File

@@ -270,6 +270,15 @@
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
((= tt :name)
(cond
((and (< (+ i 1) (len tokens)) (= (tok-type (nth tokens (+ i 1))) :assign))
(let
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
(let
((rhs-expr (parse-apl-expr rhs-tokens)))
(collect-segments-loop
tokens
(len tokens)
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)})))))
((some (fn (q) (= q tv)) apl-quad-fn-names)
(let
((op-result (collect-ops tokens (+ i 1))))
@@ -335,10 +344,22 @@
((= tt :glyph)
(cond
((or (= tv "⍺") (= tv "⍵"))
(collect-segments-loop
tokens
(+ i 1)
(append acc {:kind "val" :node (list :name tv)})))
(if
(and
(< (+ i 1) (len tokens))
(= (tok-type (nth tokens (+ i 1))) :assign))
(let
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
(let
((rhs-expr (parse-apl-expr rhs-tokens)))
(collect-segments-loop
tokens
(len tokens)
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)}))))
(collect-segments-loop
tokens
(+ i 1)
(append acc {:kind "val" :node (list :name tv)}))))
((= tv "∇")
(collect-segments-loop
tokens
@@ -393,7 +414,13 @@
ni
(append acc {:kind "fn" :node fn-node})))))))
((apl-parse-op-glyph? tv)
(collect-segments-loop tokens (+ i 1) acc))
(if
(or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
(collect-segments-loop
tokens
(+ i 1)
(append acc {:kind "fn" :node (list :fn-glyph tv)}))
(collect-segments-loop tokens (+ i 1) acc)))
(true (collect-segments-loop tokens (+ i 1) acc))))
(true (collect-segments-loop tokens (+ i 1) acc))))))))

41
lib/apl/runtime.sx
View File

@@ -808,6 +808,25 @@
((picked (map (fn (i) (nth arr-ravel i)) kept)))
(make-array (list (len picked)) picked))))))
(define
apl-compress-first
(fn
(mask arr)
(let
((mask-ravel (get mask :ravel))
(shape (get arr :shape))
(ravel (get arr :ravel)))
(if
(< (len shape) 2)
(apl-compress mask arr)
(let
((rows (first shape)) (cols (last shape)))
(let
((kept-rows (filter (fn (i) (not (= 0 (nth mask-ravel i)))) (range 0 rows))))
(let
((new-ravel (reduce (fn (acc r) (append acc (map (fn (j) (nth ravel (+ (* r cols) j))) (range 0 cols)))) (list) kept-rows)))
(make-array (cons (len kept-rows) (rest shape)) new-ravel))))))))
(define
apl-primes
(fn
@@ -985,6 +1004,28 @@
(some (fn (c) (= c 0)) codes)
(some (fn (c) (= c (nth e 1))) codes)))))
(define apl-rng-state 12345)
(define apl-rng-seed! (fn (s) (set! apl-rng-state s)))
(define
apl-rng-next!
(fn
()
(begin
(set!
apl-rng-state
(mod (+ (* apl-rng-state 1103515245) 12345) 2147483648))
apl-rng-state)))
(define
apl-roll
(fn
(arr)
(let
((n (if (scalar? arr) (first (get arr :ravel)) (first (get arr :ravel)))))
(apl-scalar (+ apl-io (mod (apl-rng-next!) n))))))
(define
apl-cartesian
(fn

143
lib/apl/tests/pipeline.sx
View File

@@ -312,3 +312,146 @@
"train: mean of ⍳10 has shape ()"
(mksh (apl-run "(+/÷≢) ⍳10"))
(list))
(apl-test
"compress: 1 0 1 0 1 / 10 20 30 40 50"
(mkrv (apl-run "1 0 1 0 1 / 10 20 30 40 50"))
(list 10 30 50))
(apl-test
"compress: empty mask → empty"
(mkrv (apl-run "0 0 0 / 1 2 3"))
(list))
(apl-test
"primes via classic idiom (multi-stmt)"
(mkrv (apl-run "P ← ⍳ 30 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"primes via classic idiom (n=20)"
(mkrv (apl-run "P ← ⍳ 20 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
(list 2 3 5 7 11 13 17 19))
(apl-test
"compress: filter even values"
(mkrv (apl-run "(0 = 2 | 1 2 3 4 5 6) / 1 2 3 4 5 6"))
(list 2 4 6))
(apl-test "inline-assign: x ← 5" (mkrv (apl-run "x ← 5")) (list 5))
(apl-test
"inline-assign: (2×x) + x←10 → 30"
(mkrv (apl-run "(2 × x) + x ← 10"))
(list 30))
(apl-test
"inline-assign primes one-liner: (2=+⌿0=a∘.|a)/a←⍳30"
(mkrv (apl-run "(2 = +⌿ 0 = a ∘.| a) / a ← ⍳ 30"))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"inline-assign: x is reusable — x + x ← 7 → 14"
(mkrv (apl-run "x + x ← 7"))
(list 14))
(apl-test
"inline-assign in dfn: f ← {x + x ← ⍵} ⋄ f 8 → 16"
(mkrv (apl-run "f ← {x + x ← ⍵} ⋄ f 8"))
(list 16))
(begin (apl-rng-seed! 42) nil)
(apl-test
"?10 with seed 42 → 8 (deterministic)"
(mkrv (apl-run "?10"))
(list 8))
(apl-test "?10 next call → 5" (mkrv (apl-run "?10")) (list 5))
(apl-test
"?100 stays in range"
(let ((v (first (mkrv (apl-run "?100"))))) (and (>= v 1) (<= v 100)))
true)
(begin (apl-rng-seed! 42) nil)
(apl-test
"?10 with re-seed 42 → 8 (reproducible)"
(mkrv (apl-run "?10"))
(list 8))
(apl-test
"apl-run-file: load primes.apl returns dfn AST"
(first (apl-run-file "lib/apl/tests/programs/primes.apl"))
:dfn)
(apl-test
"apl-run-file: life.apl parses without error"
(first (apl-run-file "lib/apl/tests/programs/life.apl"))
:dfn)
(apl-test
"apl-run-file: quicksort.apl parses without error"
(first (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
:dfn)
(apl-test
"apl-run-file: source-then-call returns primes count"
(mksh
(apl-run
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 30")))
(list 10))
(apl-test
"primes one-liner with ⍵-rebind: primes 30"
(mkrv
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 30"))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"primes one-liner: primes 50"
(mkrv
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 50"))
(list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
(apl-test
"primes.apl loaded + called via apl-run-file"
(mkrv
(apl-run
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 20")))
(list 2 3 5 7 11 13 17 19))
(apl-test
"primes.apl loaded — count of primes ≤ 100"
(first
(mksh
(apl-run
(str
(file-read "lib/apl/tests/programs/primes.apl")
" ⋄ primes 100"))))
25)
(apl-test
"⍉ monadic transpose 2x3 → 3x2"
(mkrv (apl-run "⍉ (2 3) ⍴ ⍳6"))
(list 1 4 2 5 3 6))
(apl-test
"⍉ transpose shape (3 2)"
(mksh (apl-run "⍉ (2 3) ⍴ ⍳6"))
(list 3 2))
(apl-test "⊢ monadic identity" (mkrv (apl-run "⊢ 1 2 3")) (list 1 2 3))
(apl-test
"5 ⊣ 1 2 3 → 5 (left)"
(mkrv (apl-run "5 ⊣ 1 2 3"))
(list 5))
(apl-test
"5 ⊢ 1 2 3 → 1 2 3 (right)"
(mkrv (apl-run "5 ⊢ 1 2 3"))
(list 1 2 3))
(apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")

2
lib/apl/tests/programs.sx
View File

@@ -252,8 +252,6 @@
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92))
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)

40
lib/apl/transpile.sx
View File

@@ -39,6 +39,11 @@
((= g "⊖") apl-reverse-first)
((= g "⍋") apl-grade-up)
((= g "⍒") apl-grade-down)
((= g "?") apl-roll)
((= g "⍉") apl-transpose)
((= g "⊢") (fn (a) a))
((= g "⊣") (fn (a) a))
((= g "⍕") apl-quad-fmt)
((= g "⎕FMT") apl-quad-fmt)
((= g "⎕←") apl-quad-print)
(else (error "no monadic fn for glyph")))))
@@ -80,6 +85,11 @@
((= g "∊") apl-member)
((= g "⍳") apl-index-of)
((= g "~") apl-without)
((= g "/") apl-compress)
((= g "⌿") apl-compress-first)
((= g "⍉") apl-transpose-dyadic)
((= g "⊢") (fn (a b) b))
((= g "⊣") (fn (a b) a))
(else (error "no dyadic fn for glyph")))))
(define
@@ -119,8 +129,14 @@
(let
((nm (nth node 1)))
(cond
((= nm "⍺") (get env "alpha"))
((= nm "⍵") (get env "omega"))
((= nm "⍺")
(let
((v (get env "⍺")))
(if (= v nil) (get env "alpha") v)))
((= nm "⍵")
(let
((v (get env "⍵")))
(if (= v nil) (get env "omega") v)))
((= nm "⎕IO") (apl-quad-io))
((= nm "⎕ML") (apl-quad-ml))
((= nm "⎕FR") (apl-quad-fr))
@@ -132,7 +148,11 @@
(if
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
((apl-resolve-monadic fn-node env) (apl-eval-ast arg env)))))
(let
((arg-val (apl-eval-ast arg env)))
(let
((new-env (if (and (list? arg) (> (len arg) 0) (= (first arg) :assign-expr)) (assoc env (nth arg 1) arg-val) env)))
((apl-resolve-monadic fn-node new-env) arg-val))))))
((= tag :dyad)
(let
((fn-node (nth node 1))
@@ -144,9 +164,13 @@
(get env "nabla")
(apl-eval-ast lhs env)
(apl-eval-ast rhs env))
((apl-resolve-dyadic fn-node env)
(apl-eval-ast lhs env)
(apl-eval-ast rhs env)))))
(let
((rhs-val (apl-eval-ast rhs env)))
(let
((new-env (if (and (list? rhs) (> (len rhs) 0) (= (first rhs) :assign-expr)) (assoc env (nth rhs 1) rhs-val) env)))
((apl-resolve-dyadic fn-node new-env)
(apl-eval-ast lhs new-env)
rhs-val))))))
((= tag :program) (apl-eval-stmts (rest node) env))
((= tag :dfn) node)
((= tag :bracket)
@@ -159,6 +183,8 @@
(fn (a) (if (= a :all) nil (apl-eval-ast a env)))
axis-exprs)))
(apl-bracket-multi axes arr))))
((= tag :assign-expr) (apl-eval-ast (nth node 2) env))
((= tag :assign) (apl-eval-ast (nth node 2) env))
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
(define
@@ -538,3 +564,5 @@
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
(define apl-run-file (fn (path) (apl-run (file-read path))))

20
lib/haskell/conformance.conf
View File

@@ -14,6 +14,8 @@ PRELOADS=(
lib/haskell/runtime.sx
lib/haskell/match.sx
lib/haskell/eval.sx
lib/haskell/map.sx
lib/haskell/set.sx
lib/haskell/testlib.sx
)
@@ -36,6 +38,24 @@ SUITES=(
"matrix:lib/haskell/tests/program-matrix.sx"
"wordcount:lib/haskell/tests/program-wordcount.sx"
"powers:lib/haskell/tests/program-powers.sx"
"caesar:lib/haskell/tests/program-caesar.sx"
"runlength-str:lib/haskell/tests/program-runlength-str.sx"
"showadt:lib/haskell/tests/program-showadt.sx"
"showio:lib/haskell/tests/program-showio.sx"
"partial:lib/haskell/tests/program-partial.sx"
"statistics:lib/haskell/tests/program-statistics.sx"
"newton:lib/haskell/tests/program-newton.sx"
"wordfreq:lib/haskell/tests/program-wordfreq.sx"
"mapgraph:lib/haskell/tests/program-mapgraph.sx"
"uniquewords:lib/haskell/tests/program-uniquewords.sx"
"setops:lib/haskell/tests/program-setops.sx"
"shapes:lib/haskell/tests/program-shapes.sx"
"person:lib/haskell/tests/program-person.sx"
"config:lib/haskell/tests/program-config.sx"
"counter:lib/haskell/tests/program-counter.sx"
"accumulate:lib/haskell/tests/program-accumulate.sx"
"safediv:lib/haskell/tests/program-safediv.sx"
"trycatch:lib/haskell/tests/program-trycatch.sx"
)
emit_scoreboard_json() {

293
lib/haskell/desugar.sx
View File

@@ -131,119 +131,280 @@
(let
((tag (first node)))
(cond
;; Transformations
((= tag "where")
(list
:let
(map hk-desugar (nth node 2))
: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
(hk-lc-desugar (hk-desugar (nth node 1)) (nth node 2)))
((= tag "app")
(list
:app
(hk-desugar (nth node 1))
:app (hk-desugar (nth node 1))
(hk-desugar (nth node 2))))
((= tag "p-rec")
(let
((cname (nth node 1))
(field-pats (nth node 2))
(field-order (hk-record-field-names cname)))
(cond
((nil? field-order)
(raise (str "p-rec: no record info for " cname)))
(:else
(list
:p-con
cname
(map
(fn
(fname)
(let
((p (hk-find-rec-pair field-pats fname)))
(cond
((nil? p) (list :p-wild))
(:else (hk-desugar (nth p 1))))))
field-order))))))
((= tag "rec-update")
(list
:rec-update
(hk-desugar (nth node 1))
(map
(fn (p) (list (first p) (hk-desugar (nth p 1))))
(nth node 2))))
((= tag "rec-create")
(let
((cname (nth node 1))
(field-pairs (nth node 2))
(field-order (hk-record-field-names cname)))
(cond
((nil? field-order)
(raise (str "rec-create: no record info for " cname)))
(:else
(let
((acc (list :con cname)))
(begin
(for-each
(fn
(fname)
(let
((pair
(hk-find-rec-pair field-pairs fname)))
(cond
((nil? pair)
(raise
(str
"rec-create: missing field "
fname
" for "
cname)))
(:else
(set!
acc
(list
:app
acc
(hk-desugar (nth pair 1))))))))
field-order)
acc))))))
((= tag "op")
(list
:op
(nth node 1)
: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))
: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 "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))
:range (hk-desugar (nth node 1))
(hk-desugar (nth node 2))))
((= tag "range-step")
(list
:range-step
(hk-desugar (nth node 1))
: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))))
(list :lambda (nth node 1) (hk-desugar (nth node 2))))
((= tag "let")
(list
:let
(map hk-desugar (nth node 1))
:let (map hk-desugar (nth node 1))
(hk-desugar (nth node 2))))
((= tag "case")
(list
:case
(hk-desugar (nth node 1))
:case (hk-desugar (nth node 1))
(map hk-desugar (nth node 2))))
((= tag "alt")
(list :alt (nth node 1) (hk-desugar (nth node 2))))
(list :alt (hk-desugar (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))))
(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
(list :sect-right (nth node 1) (hk-desugar (nth node 2))))
((= tag "program")
(list :program (map hk-desugar (nth node 1))))
(list :program (map hk-desugar (hk-expand-records (nth node 1)))))
((= tag "module")
(list
:module
(nth node 1)
:module (nth node 1)
(nth node 2)
(nth node 3)
(map hk-desugar (nth node 4))))
;; Decls carrying a body
(map hk-desugar (hk-expand-records (nth node 4)))))
((= tag "fun-clause")
(list
:fun-clause
(nth node 1)
(nth node 2)
:fun-clause (nth node 1)
(map hk-desugar (nth node 2))
(hk-desugar (nth node 3))))
((= tag "instance-decl")
(list
:instance-decl (nth node 1)
(nth node 2)
(map hk-desugar (nth node 3))))
((= tag "pat-bind")
(list
:pat-bind
(nth node 1)
(hk-desugar (nth node 2))))
(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, …
(list :bind (nth node 1) (hk-desugar (nth node 2))))
(:else node)))))))
;; Convenience — tokenize + layout + parse + desugar.
(define
hk-core
(fn (src) (hk-desugar (hk-parse-top src))))
(define hk-record-fields (dict))
(define
hk-core-expr
(fn (src) (hk-desugar (hk-parse src))))
hk-register-record-fields!
(fn (cname fields) (dict-set! hk-record-fields cname fields)))
(define
hk-record-field-names
(fn
(cname)
(if (has-key? hk-record-fields cname) (get hk-record-fields cname) nil)))
(define
hk-record-field-index
(fn
(cname fname)
(let
((fields (hk-record-field-names cname)))
(cond
((nil? fields) -1)
(:else
(let
((i 0) (idx -1))
(begin
(for-each
(fn
(f)
(begin (when (= f fname) (set! idx i)) (set! i (+ i 1))))
fields)
idx)))))))
(define
hk-find-rec-pair
(fn
(pairs name)
(cond
((empty? pairs) nil)
((= (first (first pairs)) name) (first pairs))
(:else (hk-find-rec-pair (rest pairs) name)))))
(define
hk-record-accessors
(fn
(cname rec-fields)
(let
((n (len rec-fields)) (i 0) (out (list)))
(define
hk-ra-loop
(fn
()
(when
(< i n)
(let
((field (nth rec-fields i)))
(let
((fname (first field)) (j 0) (pats (list)))
(define
hk-pat-loop
(fn
()
(when
(< j n)
(begin
(append!
pats
(if
(= j i)
(list "p-var" "__rec_field")
(list "p-wild")))
(set! j (+ j 1))
(hk-pat-loop)))))
(hk-pat-loop)
(append!
out
(list
"fun-clause"
fname
(list (list "p-con" cname pats))
(list "var" "__rec_field")))
(set! i (+ i 1))
(hk-ra-loop))))))
(hk-ra-loop)
out)))
(define
hk-expand-records
(fn
(decls)
(let
((out (list)))
(for-each
(fn
(d)
(cond
((and (list? d) (= (first d) "data"))
(let
((dname (nth d 1))
(tvars (nth d 2))
(cons-list (nth d 3))
(deriving (if (> (len d) 4) (nth d 4) (list)))
(new-cons (list))
(accessors (list)))
(begin
(for-each
(fn
(c)
(cond
((= (first c) "con-rec")
(let
((cname (nth c 1)) (rec-fields (nth c 2)))
(begin
(hk-register-record-fields!
cname
(map (fn (f) (first f)) rec-fields))
(append!
new-cons
(list
"con-def"
cname
(map (fn (f) (nth f 1)) rec-fields)))
(for-each
(fn (a) (append! accessors a))
(hk-record-accessors cname rec-fields)))))
(:else (append! new-cons c))))
cons-list)
(append!
out
(if
(empty? deriving)
(list "data" dname tvars new-cons)
(list "data" dname tvars new-cons deriving)))
(for-each (fn (a) (append! out a)) accessors))))
(:else (append! out d))))
decls)
out)))
(define hk-core (fn (src) (hk-desugar (hk-parse-top src))))
(define hk-core-expr (fn (src) (hk-desugar (hk-parse src))))

1023
lib/haskell/eval.sx
View File

File diff suppressed because one or more lines are too long

520
lib/haskell/map.sx Normal file
View File

@@ -0,0 +1,520 @@
;; map.sx — Phase 11 Data.Map: weight-balanced BST in pure SX.
;;
;; Algorithm: Adams's weight-balanced tree (the same family as Haskell's
;; Data.Map). Each node tracks its size; rotations maintain the invariant
;;
;; size(small-side) * delta >= size(large-side) (delta = 3)
;;
;; with single or double rotations chosen by the gamma ratio (gamma = 2).
;; The size field is an Int and is included so `size`, `lookup`, etc. are
;; O(log n) on both extremes of the tree.
;;
;; Representation:
;; Empty → ("Map-Empty")
;; Node → ("Map-Node" key val left right size)
;;
;; All operations are pure SX — no mutation of nodes once constructed.
;; The user-facing Haskell layer (Phase 11 next iteration) wraps these
;; for `import Data.Map as Map`.
;; ── Constructors ────────────────────────────────────────────
(define hk-map-empty (list "Map-Empty"))
(define
hk-map-node
(fn
(k v l r)
(list "Map-Node" k v l r (+ 1 (+ (hk-map-size l) (hk-map-size r))))))
;; ── Predicates and accessors ────────────────────────────────
(define hk-map-empty? (fn (m) (and (list? m) (= (first m) "Map-Empty"))))
(define hk-map-node? (fn (m) (and (list? m) (= (first m) "Map-Node"))))
(define
hk-map-size
(fn (m) (cond ((hk-map-empty? m) 0) (:else (nth m 5)))))
(define hk-map-key (fn (m) (nth m 1)))
(define hk-map-val (fn (m) (nth m 2)))
(define hk-map-left (fn (m) (nth m 3)))
(define hk-map-right (fn (m) (nth m 4)))
;; ── Weight-balanced rotations ───────────────────────────────
;; delta and gamma per Adams 1992 / Haskell Data.Map.
(define hk-map-delta 3)
(define hk-map-gamma 2)
(define
hk-map-single-l
(fn
(k v l r)
(let
((rk (hk-map-key r))
(rv (hk-map-val r))
(rl (hk-map-left r))
(rr (hk-map-right r)))
(hk-map-node rk rv (hk-map-node k v l rl) rr))))
(define
hk-map-single-r
(fn
(k v l r)
(let
((lk (hk-map-key l))
(lv (hk-map-val l))
(ll (hk-map-left l))
(lr (hk-map-right l)))
(hk-map-node lk lv ll (hk-map-node k v lr r)))))
(define
hk-map-double-l
(fn
(k v l r)
(let
((rk (hk-map-key r))
(rv (hk-map-val r))
(rl (hk-map-left r))
(rr (hk-map-right r))
(rlk (hk-map-key (hk-map-left r)))
(rlv (hk-map-val (hk-map-left r)))
(rll (hk-map-left (hk-map-left r)))
(rlr (hk-map-right (hk-map-left r))))
(hk-map-node
rlk
rlv
(hk-map-node k v l rll)
(hk-map-node rk rv rlr rr)))))
(define
hk-map-double-r
(fn
(k v l r)
(let
((lk (hk-map-key l))
(lv (hk-map-val l))
(ll (hk-map-left l))
(lr (hk-map-right l))
(lrk (hk-map-key (hk-map-right l)))
(lrv (hk-map-val (hk-map-right l)))
(lrl (hk-map-left (hk-map-right l)))
(lrr (hk-map-right (hk-map-right l))))
(hk-map-node
lrk
lrv
(hk-map-node lk lv ll lrl)
(hk-map-node k v lrr r)))))
;; ── Balanced node constructor ──────────────────────────────
;; Use this in place of hk-map-node when one side may have grown
;; or shrunk by one and we need to restore the weight invariant.
(define
hk-map-balance
(fn
(k v l r)
(let
((sl (hk-map-size l)) (sr (hk-map-size r)))
(cond
((<= (+ sl sr) 1) (hk-map-node k v l r))
((> sr (* hk-map-delta sl))
(let
((rl (hk-map-left r)) (rr (hk-map-right r)))
(cond
((< (hk-map-size rl) (* hk-map-gamma (hk-map-size rr)))
(hk-map-single-l k v l r))
(:else (hk-map-double-l k v l r)))))
((> sl (* hk-map-delta sr))
(let
((ll (hk-map-left l)) (lr (hk-map-right l)))
(cond
((< (hk-map-size lr) (* hk-map-gamma (hk-map-size ll)))
(hk-map-single-r k v l r))
(:else (hk-map-double-r k v l r)))))
(:else (hk-map-node k v l r))))))
(define
hk-map-singleton
(fn (k v) (hk-map-node k v hk-map-empty hk-map-empty)))
(define
hk-map-insert
(fn
(k v m)
(cond
((hk-map-empty? m) (hk-map-singleton k v))
(:else
(let
((mk (hk-map-key m)))
(cond
((< k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-insert k v (hk-map-left m))
(hk-map-right m)))
((> k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-left m)
(hk-map-insert k v (hk-map-right m))))
(:else (hk-map-node k v (hk-map-left m) (hk-map-right m)))))))))
(define
hk-map-lookup
(fn
(k m)
(cond
((hk-map-empty? m) (list "Nothing"))
(:else
(let
((mk (hk-map-key m)))
(cond
((< k mk) (hk-map-lookup k (hk-map-left m)))
((> k mk) (hk-map-lookup k (hk-map-right m)))
(:else (list "Just" (hk-map-val m)))))))))
(define
hk-map-member
(fn
(k m)
(cond
((hk-map-empty? m) false)
(:else
(let
((mk (hk-map-key m)))
(cond
((< k mk) (hk-map-member k (hk-map-left m)))
((> k mk) (hk-map-member k (hk-map-right m)))
(:else true)))))))
(define hk-map-null hk-map-empty?)
(define
hk-map-find-min
(fn
(m)
(cond
((hk-map-empty? (hk-map-left m))
(list (hk-map-key m) (hk-map-val m)))
(:else (hk-map-find-min (hk-map-left m))))))
(define
hk-map-delete-min
(fn
(m)
(cond
((hk-map-empty? (hk-map-left m)) (hk-map-right m))
(:else
(hk-map-balance
(hk-map-key m)
(hk-map-val m)
(hk-map-delete-min (hk-map-left m))
(hk-map-right m))))))
(define
hk-map-find-max
(fn
(m)
(cond
((hk-map-empty? (hk-map-right m))
(list (hk-map-key m) (hk-map-val m)))
(:else (hk-map-find-max (hk-map-right m))))))
(define
hk-map-delete-max
(fn
(m)
(cond
((hk-map-empty? (hk-map-right m)) (hk-map-left m))
(:else
(hk-map-balance
(hk-map-key m)
(hk-map-val m)
(hk-map-left m)
(hk-map-delete-max (hk-map-right m)))))))
(define
hk-map-glue
(fn
(l r)
(cond
((hk-map-empty? l) r)
((hk-map-empty? r) l)
((> (hk-map-size l) (hk-map-size r))
(let
((mp (hk-map-find-max l)))
(hk-map-balance (first mp) (nth mp 1) (hk-map-delete-max l) r)))
(:else
(let
((mp (hk-map-find-min r)))
(hk-map-balance (first mp) (nth mp 1) l (hk-map-delete-min r)))))))
(define
hk-map-delete
(fn
(k m)
(cond
((hk-map-empty? m) m)
(:else
(let
((mk (hk-map-key m)))
(cond
((< k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-delete k (hk-map-left m))
(hk-map-right m)))
((> k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-left m)
(hk-map-delete k (hk-map-right m))))
(:else (hk-map-glue (hk-map-left m) (hk-map-right m)))))))))
(define
hk-map-from-list
(fn
(pairs)
(reduce
(fn (acc p) (hk-map-insert (first p) (nth p 1) acc))
hk-map-empty
pairs)))
(define
hk-map-to-asc-list
(fn
(m)
(cond
((hk-map-empty? m) (list))
(:else
(append
(hk-map-to-asc-list (hk-map-left m))
(cons
(list (hk-map-key m) (hk-map-val m))
(hk-map-to-asc-list (hk-map-right m))))))))
(define hk-map-to-list hk-map-to-asc-list)
(define
hk-map-keys
(fn
(m)
(cond
((hk-map-empty? m) (list))
(:else
(append
(hk-map-keys (hk-map-left m))
(cons (hk-map-key m) (hk-map-keys (hk-map-right m))))))))
(define
hk-map-elems
(fn
(m)
(cond
((hk-map-empty? m) (list))
(:else
(append
(hk-map-elems (hk-map-left m))
(cons (hk-map-val m) (hk-map-elems (hk-map-right m))))))))
(define
hk-map-union-with
(fn
(f m1 m2)
(reduce
(fn
(acc p)
(let
((k (first p)) (v (nth p 1)))
(let
((look (hk-map-lookup k acc)))
(cond
((= (first look) "Just")
(hk-map-insert k (f (nth look 1) v) acc))
(:else (hk-map-insert k v acc))))))
m1
(hk-map-to-asc-list m2))))
(define
hk-map-intersection-with
(fn
(f m1 m2)
(reduce
(fn
(acc p)
(let
((k (first p)) (v1 (nth p 1)))
(let
((look (hk-map-lookup k m2)))
(cond
((= (first look) "Just")
(hk-map-insert k (f v1 (nth look 1)) acc))
(:else acc)))))
hk-map-empty
(hk-map-to-asc-list m1))))
(define
hk-map-difference
(fn
(m1 m2)
(reduce
(fn
(acc p)
(let
((k (first p)) (v (nth p 1)))
(cond ((hk-map-member k m2) acc) (:else (hk-map-insert k v acc)))))
hk-map-empty
(hk-map-to-asc-list m1))))
(define
hk-map-foldl-with-key
(fn
(f acc m)
(cond
((hk-map-empty? m) acc)
(:else
(let
((acc1 (hk-map-foldl-with-key f acc (hk-map-left m))))
(let
((acc2 (f acc1 (hk-map-key m) (hk-map-val m))))
(hk-map-foldl-with-key f acc2 (hk-map-right m))))))))
(define
hk-map-foldr-with-key
(fn
(f acc m)
(cond
((hk-map-empty? m) acc)
(:else
(let
((acc1 (hk-map-foldr-with-key f acc (hk-map-right m))))
(let
((acc2 (f (hk-map-key m) (hk-map-val m) acc1)))
(hk-map-foldr-with-key f acc2 (hk-map-left m))))))))
(define
hk-map-map-with-key
(fn
(f m)
(cond
((hk-map-empty? m) m)
(:else
(list
"Map-Node"
(hk-map-key m)
(f (hk-map-key m) (hk-map-val m))
(hk-map-map-with-key f (hk-map-left m))
(hk-map-map-with-key f (hk-map-right m))
(hk-map-size m))))))
(define
hk-map-filter-with-key
(fn
(p m)
(hk-map-foldr-with-key
(fn (k v acc) (cond ((p k v) (hk-map-insert k v acc)) (:else acc)))
hk-map-empty
m)))
(define
hk-map-adjust
(fn
(f k m)
(cond
((hk-map-empty? m) m)
(:else
(let
((mk (hk-map-key m)))
(cond
((< k mk)
(hk-map-node
mk
(hk-map-val m)
(hk-map-adjust f k (hk-map-left m))
(hk-map-right m)))
((> k mk)
(hk-map-node
mk
(hk-map-val m)
(hk-map-left m)
(hk-map-adjust f k (hk-map-right m))))
(:else
(hk-map-node
mk
(f (hk-map-val m))
(hk-map-left m)
(hk-map-right m)))))))))
(define
hk-map-insert-with
(fn
(f k v m)
(cond
((hk-map-empty? m) (hk-map-singleton k v))
(:else
(let
((mk (hk-map-key m)))
(cond
((< k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-insert-with f k v (hk-map-left m))
(hk-map-right m)))
((> k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-left m)
(hk-map-insert-with f k v (hk-map-right m))))
(:else
(hk-map-node
mk
(f v (hk-map-val m))
(hk-map-left m)
(hk-map-right m)))))))))
(define
hk-map-insert-with-key
(fn
(f k v m)
(cond
((hk-map-empty? m) (hk-map-singleton k v))
(:else
(let
((mk (hk-map-key m)))
(cond
((< k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-insert-with-key f k v (hk-map-left m))
(hk-map-right m)))
((> k mk)
(hk-map-balance
mk
(hk-map-val m)
(hk-map-left m)
(hk-map-insert-with-key f k v (hk-map-right m))))
(:else
(hk-map-node
mk
(f k v (hk-map-val m))
(hk-map-left m)
(hk-map-right m)))))))))
(define
hk-map-alter
(fn
(f k m)
(let
((look (hk-map-lookup k m)))
(let
((res (f look)))
(cond
((= (first res) "Nothing") (hk-map-delete k m))
(:else (hk-map-insert k (nth res 1) m)))))))

76
lib/haskell/match.sx
View File

@@ -87,45 +87,41 @@
((nil? res) nil)
(:else (assoc res (nth pat 1) val)))))
(:else
(let ((fv (hk-force val)))
(let
((fv (hk-force val)))
(cond
((= tag "p-int")
(if
(and (number? fv) (= fv (nth pat 1)))
env
nil))
(if (and (number? fv) (= fv (nth pat 1))) env nil))
((= tag "p-float")
(if
(and (number? fv) (= fv (nth pat 1)))
env
nil))
(if (and (number? fv) (= fv (nth pat 1))) env nil))
((= tag "p-string")
(if
(and (string? fv) (= fv (nth pat 1)))
env
nil))
(if (and (string? fv) (= fv (nth pat 1))) env nil))
((= tag "p-char")
(if
(and (string? fv) (= fv (nth pat 1)))
env
nil))
(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
((and (= pat-name ":") (hk-str? fv) (not (hk-str-null? fv)))
(let
((str-head (hk-str-head fv))
(str-tail (hk-str-tail fv)))
(let
((head-pat (nth pat-args 0))
(tail-pat (nth pat-args 1)))
(let
((res (hk-match head-pat str-head env)))
(cond
((nil? res) nil)
(:else (hk-match tail-pat str-tail res)))))))
((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))))))))
((not (= (len val-args) (len pat-args))) nil)
(:else (hk-match-all pat-args val-args env))))))))
((= tag "p-tuple")
(let
((items (nth pat 1)))
@@ -134,13 +130,8 @@
((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 (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
@@ -161,17 +152,26 @@
hk-match-list-pat
(fn
(items val env)
(let ((fv (hk-force val)))
(let
((fv (hk-force val)))
(cond
((empty? items)
(if
(and
(hk-is-con-val? fv)
(= (hk-val-con-name fv) "[]"))
(or
(and (hk-is-con-val? fv) (= (hk-val-con-name fv) "[]"))
(and (hk-str? fv) (hk-str-null? fv)))
env
nil))
(:else
(cond
((and (hk-str? fv) (not (hk-str-null? fv)))
(let
((h (hk-str-head fv)) (t (hk-str-tail fv)))
(let
((res (hk-match (first items) h env)))
(cond
((nil? res) nil)
(:else (hk-match-list-pat (rest items) t res))))))
((not (hk-is-con-val? fv)) nil)
((not (= (hk-val-con-name fv) ":")) nil)
(:else
@@ -183,11 +183,7 @@
((res (hk-match (first items) h env)))
(cond
((nil? res) nil)
(:else
(hk-match-list-pat
(rest items)
t
res)))))))))))))
(: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` —

184
lib/haskell/parser.sx
View File

@@ -208,9 +208,19 @@
((= (get t "type") "char")
(do (hk-advance!) (list :char (get t "value"))))
((= (get t "type") "varid")
(do (hk-advance!) (list :var (get t "value"))))
(do
(hk-advance!)
(cond
((hk-match? "lbrace" nil)
(hk-parse-rec-update (list :var (get t "value"))))
(:else (list :var (get t "value"))))))
((= (get t "type") "conid")
(do (hk-advance!) (list :con (get t "value"))))
(do
(hk-advance!)
(cond
((hk-match? "lbrace" nil)
(hk-parse-rec-create (get t "value")))
(:else (list :con (get t "value"))))))
((= (get t "type") "qvarid")
(do (hk-advance!) (list :var (get t "value"))))
((= (get t "type") "qconid")
@@ -456,6 +466,90 @@
(do
(hk-expect! "rbracket" nil)
(list :list (list first-e))))))))))
(define
hk-parse-rec-create
(fn
(cname)
(begin
(hk-expect! "lbrace" nil)
(let
((fields (list)))
(define
hk-rc-loop
(fn
()
(when
(hk-match? "varid" nil)
(let
((fname (get (hk-advance!) "value")))
(begin
(hk-expect! "reservedop" "=")
(let
((fexpr (hk-parse-expr-inner)))
(begin
(append! fields (list fname fexpr))
(when
(hk-match? "comma" nil)
(begin (hk-advance!) (hk-rc-loop))))))))))
(hk-rc-loop)
(hk-expect! "rbrace" nil)
(list :rec-create cname fields)))))
(define
hk-parse-rec-update
(fn
(rec-expr)
(begin
(hk-expect! "lbrace" nil)
(let
((fields (list)))
(define
hk-ru-loop
(fn
()
(when
(hk-match? "varid" nil)
(let
((fname (get (hk-advance!) "value")))
(begin
(hk-expect! "reservedop" "=")
(let
((fexpr (hk-parse-expr-inner)))
(begin
(append! fields (list fname fexpr))
(when
(hk-match? "comma" nil)
(begin (hk-advance!) (hk-ru-loop))))))))))
(hk-ru-loop)
(hk-expect! "rbrace" nil)
(list :rec-update rec-expr fields)))))
(define
hk-parse-rec-pat
(fn
(cname)
(begin
(hk-expect! "lbrace" nil)
(let
((field-pats (list)))
(define
hk-rp-loop
(fn
()
(when
(hk-match? "varid" nil)
(let
((fname (get (hk-advance!) "value")))
(begin
(hk-expect! "reservedop" "=")
(let
((fpat (hk-parse-pat)))
(begin
(append! field-pats (list fname fpat))
(when
(hk-match? "comma" nil)
(begin (hk-advance!) (hk-rp-loop))))))))))
(hk-rp-loop)
(hk-expect! "rbrace" nil)
(list :p-rec cname field-pats)))))
(define
hk-parse-fexp
(fn
@@ -696,7 +790,12 @@
(:else
(do (hk-advance!) (list :p-var (get t "value")))))))
((= (get t "type") "conid")
(do (hk-advance!) (list :p-con (get t "value") (list))))
(do
(hk-advance!)
(cond
((hk-match? "lbrace" nil)
(hk-parse-rec-pat (get t "value")))
(:else (list :p-con (get t "value") (list))))))
((= (get t "type") "qconid")
(do (hk-advance!) (list :p-con (get t "value") (list))))
((= (get t "type") "lparen") (hk-parse-paren-pat))
@@ -762,16 +861,24 @@
(cond
((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
(let
((name (get (hk-advance!) "value")) (args (list)))
(define
hk-pca-loop
(fn
()
(when
(hk-apat-start? (hk-peek))
(do (append! args (hk-parse-apat)) (hk-pca-loop)))))
(hk-pca-loop)
(list :p-con name args)))
((name (get (hk-advance!) "value")))
(cond
((hk-match? "lbrace" nil)
(hk-parse-rec-pat name))
(:else
(let
((args (list)))
(define
hk-pca-loop
(fn
()
(when
(hk-apat-start? (hk-peek))
(do
(append! args (hk-parse-apat))
(hk-pca-loop)))))
(hk-pca-loop)
(list :p-con name args))))))
(:else (hk-parse-apat))))))
(define
hk-parse-pat
@@ -1212,16 +1319,47 @@
(not (hk-match? "conid" nil))
(hk-err "expected constructor name"))
(let
((name (get (hk-advance!) "value")) (fields (list)))
(define
hk-cd-loop
(fn
()
(when
(hk-atype-start? (hk-peek))
(do (append! fields (hk-parse-atype)) (hk-cd-loop)))))
(hk-cd-loop)
(list :con-def name fields))))
((name (get (hk-advance!) "value")))
(cond
((hk-match? "lbrace" nil)
(begin
(hk-advance!)
(let
((rec-fields (list)))
(define
hk-rec-loop
(fn
()
(when
(hk-match? "varid" nil)
(let
((fname (get (hk-advance!) "value")))
(begin
(hk-expect! "reservedop" "::")
(let
((ftype (hk-parse-type)))
(begin
(append! rec-fields (list fname ftype))
(when
(hk-match? "comma" nil)
(begin (hk-advance!) (hk-rec-loop))))))))))
(hk-rec-loop)
(hk-expect! "rbrace" nil)
(list :con-rec name rec-fields))))
(:else
(let
((fields (list)))
(define
hk-cd-loop
(fn
()
(when
(hk-atype-start? (hk-peek))
(begin
(append! fields (hk-parse-atype))
(hk-cd-loop)))))
(hk-cd-loop)
(list :con-def name fields)))))))
(define
hk-parse-tvars
(fn

96
lib/haskell/runtime.sx
View File

@@ -12,12 +12,7 @@
(define
hk-register-con!
(fn
(cname arity type-name)
(dict-set!
hk-constructors
cname
{:arity arity :type type-name})))
(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)))
@@ -48,26 +43,15 @@
(fn
(data-node)
(let
((type-name (nth data-node 1))
(cons-list (nth data-node 3)))
((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))
(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))))
(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
@@ -78,15 +62,9 @@
(fn
(d)
(cond
((and
(list? d)
(not (empty? d))
(= (first d) "data"))
((and (list? d) (not (empty? d)) (= (first d) "data"))
(hk-register-data! d))
((and
(list? d)
(not (empty? d))
(= (first d) "newtype"))
((and (list? d) (not (empty? d)) (= (first d) "newtype"))
(hk-register-newtype! d))
(:else nil)))
decls)))
@@ -99,16 +77,12 @@
((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)))
((= (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))))
(define hk-load-source! (fn (src) (hk-register-program! (hk-core src))))
;; ── Built-in constructors pre-registered ─────────────────────
;; Bool — used implicitly by `if`, comparison operators.
@@ -122,9 +96,55 @@
;; 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! "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")
(hk-register-con! "SomeException" 1 "SomeException")
(define
hk-str?
(fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str")))))
(define
hk-str-head
(fn
(v)
(if
(string? v)
(char-code (char-at v 0))
(char-code (char-at (get v "hk-str") (get v "hk-off"))))))
(define
hk-str-tail
(fn
(v)
(let
((buf (if (string? v) v (get v "hk-str")))
(off (if (string? v) 1 (+ (get v "hk-off") 1))))
(if (>= off (string-length buf)) (list "[]") {:hk-off off :hk-str buf}))))
(define
hk-str-null?
(fn
(v)
(if
(string? v)
(= (string-length v) 0)
(>= (get v "hk-off") (string-length (get v "hk-str"))))))
(define
hk-str-to-native
(fn
(v)
(if
(string? v)
v
(let
((buf (get v "hk-str")) (off (get v "hk-off")))
(reduce
(fn (acc i) (str acc (char-at buf i)))
""
(range off (string-length buf)))))))

28
lib/haskell/scoreboard.json
View File

@@ -1,6 +1,6 @@
{
"date": "2026-05-06",
"total_pass": 156,
"date": "2026-05-08",
"total_pass": 285,
"total_fail": 0,
"programs": {
"fib": {"pass": 2, "fail": 0},
@@ -9,7 +9,7 @@
"nqueens": {"pass": 2, "fail": 0},
"calculator": {"pass": 5, "fail": 0},
"collatz": {"pass": 11, "fail": 0},
"palindrome": {"pass": 8, "fail": 0},
"palindrome": {"pass": 12, "fail": 0},
"maybe": {"pass": 12, "fail": 0},
"fizzbuzz": {"pass": 12, "fail": 0},
"anagram": {"pass": 9, "fail": 0},
@@ -19,7 +19,25 @@
"primes": {"pass": 12, "fail": 0},
"zipwith": {"pass": 9, "fail": 0},
"matrix": {"pass": 8, "fail": 0},
"wordcount": {"pass": 7, "fail": 0},
"powers": {"pass": 14, "fail": 0}
"wordcount": {"pass": 10, "fail": 0},
"powers": {"pass": 14, "fail": 0},
"caesar": {"pass": 8, "fail": 0},
"runlength-str": {"pass": 9, "fail": 0},
"showadt": {"pass": 5, "fail": 0},
"showio": {"pass": 5, "fail": 0},
"partial": {"pass": 7, "fail": 0},
"statistics": {"pass": 5, "fail": 0},
"newton": {"pass": 5, "fail": 0},
"wordfreq": {"pass": 7, "fail": 0},
"mapgraph": {"pass": 6, "fail": 0},
"uniquewords": {"pass": 4, "fail": 0},
"setops": {"pass": 8, "fail": 0},
"shapes": {"pass": 5, "fail": 0},
"person": {"pass": 7, "fail": 0},
"config": {"pass": 10, "fail": 0},
"counter": {"pass": 7, "fail": 0},
"accumulate": {"pass": 8, "fail": 0},
"safediv": {"pass": 8, "fail": 0},
"trycatch": {"pass": 8, "fail": 0}
}
}

26
lib/haskell/scoreboard.md
View File

@@ -1,6 +1,6 @@
# Haskell-on-SX Scoreboard
Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
| Program | Tests | Status |
|---------|-------|--------|
@@ -10,7 +10,7 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
| nqueens.hs | 2/2 | ✓ |
| calculator.hs | 5/5 | ✓ |
| collatz.hs | 11/11 | ✓ |
| palindrome.hs | 8/8 | ✓ |
| palindrome.hs | 12/12 | ✓ |
| maybe.hs | 12/12 | ✓ |
| fizzbuzz.hs | 12/12 | ✓ |
| anagram.hs | 9/9 | ✓ |
@@ -20,6 +20,24 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
| primes.hs | 12/12 | ✓ |
| zipwith.hs | 9/9 | ✓ |
| matrix.hs | 8/8 | ✓ |
| wordcount.hs | 7/7 | ✓ |
| wordcount.hs | 10/10 | ✓ |
| powers.hs | 14/14 | ✓ |
| **Total** | **156/156** | **18/18 programs** |
| caesar.hs | 8/8 | ✓ |
| runlength-str.hs | 9/9 | ✓ |
| showadt.hs | 5/5 | ✓ |
| showio.hs | 5/5 | ✓ |
| partial.hs | 7/7 | ✓ |
| statistics.hs | 5/5 | ✓ |
| newton.hs | 5/5 | ✓ |
| wordfreq.hs | 7/7 | ✓ |
| mapgraph.hs | 6/6 | ✓ |
| uniquewords.hs | 4/4 | ✓ |
| setops.hs | 8/8 | ✓ |
| shapes.hs | 5/5 | ✓ |
| person.hs | 7/7 | ✓ |
| config.hs | 10/10 | ✓ |
| counter.hs | 7/7 | ✓ |
| accumulate.hs | 8/8 | ✓ |
| safediv.hs | 8/8 | ✓ |
| trycatch.hs | 8/8 | ✓ |
| **Total** | **285/285** | **36/36 programs** |

62
lib/haskell/set.sx Normal file
View File

@@ -0,0 +1,62 @@
;; set.sx — Phase 12 Data.Set: wraps Data.Map with unit values.
;;
;; A Set is a Map from key to (). All set operations delegate to the map
;; ops, ignoring the value side. Storage representation matches Data.Map:
;;
;; Empty → ("Map-Empty")
;; Node → ("Map-Node" key () left right size)
;;
;; Tradeoff: trivial maintenance burden, slight overhead per node from
;; the unused value slot. Faster path forward than re-implementing the
;; weight-balanced BST.
;;
;; Functions live in this file; the Haskell-level `import Data.Set` /
;; `import qualified Data.Set as Set` wiring (next Phase 12 box) binds
;; them under the chosen alias.
(define hk-set-unit (list "Tuple"))
(define hk-set-empty hk-map-empty)
(define hk-set-singleton (fn (k) (hk-map-singleton k hk-set-unit)))
(define hk-set-insert (fn (k s) (hk-map-insert k hk-set-unit s)))
(define hk-set-delete hk-map-delete)
(define hk-set-member hk-map-member)
(define hk-set-size hk-map-size)
(define hk-set-null hk-map-null)
(define hk-set-to-asc-list hk-map-keys)
(define hk-set-to-list hk-map-keys)
(define
hk-set-from-list
(fn (xs) (reduce (fn (acc k) (hk-set-insert k acc)) hk-set-empty xs)))
(define
hk-set-union
(fn (a b) (hk-map-union-with (fn (x y) hk-set-unit) a b)))
(define
hk-set-intersection
(fn (a b) (hk-map-intersection-with (fn (x y) hk-set-unit) a b)))
(define hk-set-difference hk-map-difference)
(define
hk-set-is-subset-of
(fn (a b) (= (hk-map-size (hk-map-difference a b)) 0)))
(define
hk-set-filter
(fn (p s) (hk-map-filter-with-key (fn (k v) (p k)) s)))
(define hk-set-map (fn (f s) (hk-set-from-list (map f (hk-map-keys s)))))
(define
hk-set-foldr
(fn (f z s) (hk-map-foldr-with-key (fn (k v acc) (f k acc)) z s)))
(define
hk-set-foldl
(fn (f z s) (hk-map-foldl-with-key (fn (acc k v) (f acc k)) z s)))

4
lib/haskell/test.sh
View File

@@ -55,6 +55,8 @@ for FILE in "${FILES[@]}"; do
(load "lib/haskell/runtime.sx")
(load "lib/haskell/match.sx")
(load "lib/haskell/eval.sx")
(load "lib/haskell/map.sx")
(load "lib/haskell/set.sx")
$INFER_LOAD
(load "lib/haskell/testlib.sx")
(epoch 2)
@@ -98,6 +100,8 @@ EPOCHS
(load "lib/haskell/runtime.sx")
(load "lib/haskell/match.sx")
(load "lib/haskell/eval.sx")
(load "lib/haskell/map.sx")
(load "lib/haskell/set.sx")
$INFER_LOAD
(load "lib/haskell/testlib.sx")
(epoch 2)

18
lib/haskell/testlib.sx
View File

@@ -56,3 +56,21 @@
(append!
hk-test-fails
{:actual actual :expected expected :name name})))))
(define
hk-test-error
(fn
(name thunk expected-substring)
(let
((caught (guard (e (true (if (string? e) e (str e)))) (begin (thunk) nil))))
(cond
((nil? caught)
(do
(set! hk-test-fail (+ hk-test-fail 1))
(append! hk-test-fails {:actual "no error raised" :expected (str "error containing: " expected-substring) :name name})))
((>= (index-of caught expected-substring) 0)
(set! hk-test-pass (+ hk-test-pass 1)))
(:else
(do
(set! hk-test-fail (+ hk-test-fail 1))
(append! hk-test-fails {:actual caught :expected (str "error containing: " expected-substring) :name name})))))))

86
lib/haskell/tests/class-defaults.sx Normal file
View File

@@ -0,0 +1,86 @@
;; class-defaults.sx — Phase 13: class default method implementations.
;; ── Eq default: myNeq derived from myEq via `not (myEq x y)` ──
(define
hk-myeq-source
"class MyEq a where\n myEq :: a -> a -> Bool\n myNeq :: a -> a -> Bool\n myNeq x y = not (myEq x y)\ninstance MyEq Int where\n myEq x y = x == y\n")
(hk-test
"Eq default: myNeq 3 5 = True (no explicit myNeq in instance)"
(hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 5\n")))
(list "True"))
(hk-test
"Eq default: myNeq 3 3 = False"
(hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 3\n")))
(list "False"))
(hk-test
"Eq default: myEq still works in same instance"
(hk-deep-force (hk-run (str hk-myeq-source "main = myEq 7 7\n")))
(list "True"))
;; ── Override path: instance can still provide the method explicitly. ──
(hk-test
"Default override: instance-provided beats class default"
(hk-deep-force
(hk-run
"class Hi a where\n greet :: a -> String\n greet x = \"default\"\ninstance Hi Bool where\n greet x = \"override\"\nmain = greet True"))
"override")
(hk-test
"Default fallback: empty instance picks default"
(hk-deep-force
(hk-run
"class Hi a where\n greet :: a -> String\n greet x = \"default\"\ninstance Hi Bool where\nmain = greet True"))
"default")
(define
hk-myord-source
"class MyOrd a where\n myCmp :: a -> a -> Bool\n myMax :: a -> a -> a\n myMin :: a -> a -> a\n myMax a b = if myCmp a b then a else b\n myMin a b = if myCmp a b then b else a\ninstance MyOrd Int where\n myCmp x y = x >= y\n")
(hk-test
"Ord default: myMax 3 5 = 5"
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 3 5\n")))
5)
(hk-test
"Ord default: myMax 8 2 = 8"
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 8 2\n")))
8)
(hk-test
"Ord default: myMin 3 5 = 3"
(hk-deep-force (hk-run (str hk-myord-source "main = myMin 3 5\n")))
3)
(hk-test
"Ord default: myMin 8 2 = 2"
(hk-deep-force (hk-run (str hk-myord-source "main = myMin 8 2\n")))
2)
(hk-test
"Ord default: myMax of equals returns first"
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 4 4\n")))
4)
(define
hk-mynum-source
"class MyNum a where\n mySub :: a -> a -> a\n myLt :: a -> a -> Bool\n myNegate :: a -> a\n myAbs :: a -> a\n myNegate x = mySub (mySub x x) x\n myAbs x = if myLt x (mySub x x) then myNegate x else x\ninstance MyNum Int where\n mySub x y = x - y\n myLt x y = x < y\n")
(hk-test
"Num default: myNegate 5 = -5"
(hk-deep-force (hk-run (str hk-mynum-source "main = myNegate 5\n")))
-5)
(hk-test
"Num default: myAbs (myNegate 7) = 7"
(hk-deep-force (hk-run (str hk-mynum-source "main = myAbs (myNegate 7)\n")))
7)
(hk-test
"Num default: myAbs 9 = 9"
(hk-deep-force (hk-run (str hk-mynum-source "main = myAbs 9\n")))
9)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

35
lib/haskell/tests/deriving.sx
View File

@@ -12,14 +12,14 @@
"deriving Show: constructor with arg"
(hk-deep-force
(hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
"(Wrap 42)")
"Wrap 42")
(hk-test
"deriving Show: nested constructors"
(hk-deep-force
(hk-run
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
"(Node 1 Leaf Leaf)")
"Node 1 Leaf Leaf")
(hk-test
"deriving Show: second constructor"
@@ -30,6 +30,31 @@
;; ─── Eq ──────────────────────────────────────────────────────────────────────
(hk-test
"deriving Show: nested ADT wraps inner constructor in parens"
(hk-deep-force
(hk-run
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf (Node 2 Leaf Leaf))"))
"Node 1 Leaf (Node 2 Leaf Leaf)")
(hk-test
"deriving Show: Maybe Maybe wraps inner Just"
(hk-deep-force (hk-run "main = show (Just (Just 3))"))
"Just (Just 3)")
(hk-test
"deriving Show: negative argument wrapped in parens"
(hk-deep-force (hk-run "main = show (Just (negate 3))"))
"Just (-3)")
(hk-test
"deriving Show: list element does not need parens"
(hk-deep-force
(hk-run "data Box = Box [Int] deriving (Show)\nmain = show (Box [1,2,3])"))
"Box [1,2,3]")
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
(hk-test
"deriving Eq: same constructor"
(hk-deep-force
@@ -58,14 +83,12 @@
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
"True")
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
(hk-test
"deriving Eq Show: combined in parens"
"deriving Eq Show: combined"
(hk-deep-force
(hk-run
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
"(Circle 5)")
"Circle 5")
(hk-test
"deriving Eq Show: eq on constructor with arg"

99
lib/haskell/tests/errors.sx Normal file
View File

@@ -0,0 +1,99 @@
;; errors.sx — Phase 9 error / undefined / partial-fn coverage via hk-test-error.
;; ── error builtin ────────────────────────────────────────────
(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))))
(hk-test-error
"error: raises with literal message"
(fn () (hk-deep-force (hk-run "main = error \"boom\"")))
"hk-error: boom")
(hk-test-error
"error: raises with computed message"
(fn () (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)")))
"hk-error: oops: 42")
;; ── undefined ────────────────────────────────────────────────
(hk-test-error
"error: nested in if branch (only fires when forced)"
(fn
()
(hk-deep-force (hk-run "main = if 1 == 1 then error \"taken\" else 0")))
"taken")
(hk-test-error
"undefined: raises Prelude.undefined"
(fn () (hk-deep-force (hk-run "main = undefined")))
"Prelude.undefined")
;; The non-strict path: undefined doesn't fire when not forced.
(hk-test-error
"undefined: forced via arithmetic"
(fn () (hk-deep-force (hk-run "main = undefined + 1")))
"Prelude.undefined")
;; ── partial functions ───────────────────────────────────────
(hk-test
"undefined: lazy, not forced when discarded"
(hk-deep-force (hk-run "main = let _ = undefined in 5"))
5)
(hk-test-error
"head []: raises Prelude.head: empty list"
(fn () (hk-deep-force (hk-run "main = head []")))
"Prelude.head: empty list")
(hk-test-error
"tail []: raises Prelude.tail: empty list"
(fn () (hk-deep-force (hk-run "main = tail []")))
"Prelude.tail: empty list")
;; head and tail still work on non-empty lists.
(hk-test-error
"fromJust Nothing: raises Maybe.fromJust: Nothing"
(fn () (hk-deep-force (hk-run "main = fromJust Nothing")))
"Maybe.fromJust: Nothing")
(hk-test
"head [42]: still works"
(hk-deep-force (hk-run "main = head [42]"))
42)
;; ── error in IO context ─────────────────────────────────────
(hk-test
"tail [1,2,3]: still works"
(hk-as-list (hk-deep-force (hk-run "main = tail [1,2,3]")))
(list 2 3))
(hk-test
"hk-run-io: error in main lands in io-lines"
(let
((lines (hk-run-io "main = error \"caught here\"")))
(>= (index-of (str lines) "caught here") 0))
true)
;; ── hk-test-error helper itself ─────────────────────────────
(hk-test
"hk-run-io: putStrLn before error preserves earlier output"
(let
((lines (hk-run-io "main = do { putStrLn \"first\"; error \"died\"; putStrLn \"never\" }")))
(and
(>= (index-of (str lines) "first") 0)
(>= (index-of (str lines) "died") 0)))
true)
;; hk-as-list helper for converting a forced Haskell cons into an SX list.
(hk-test-error
"hk-test-error: matches partial substring inside wrapped exception"
(fn () (hk-deep-force (hk-run "main = error \"unique-marker-xyz\"")))
"unique-marker-xyz")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

81
lib/haskell/tests/eval.sx
View File

@@ -231,16 +231,82 @@
1)
;; ── Laziness: app args evaluate only when forced ──
(hk-test
"error builtin: raises with hk-error prefix"
(guard
(e (true (>= (index-of e "hk-error: boom") 0)))
(begin (hk-deep-force (hk-run "main = error \"boom\"")) false))
true)
(hk-test
"error builtin: raises with computed message"
(guard
(e (true (>= (index-of e "hk-error: oops: 42") 0)))
(begin
(hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)"))
false))
true)
(hk-test
"undefined: raises hk-error with Prelude.undefined message"
(guard
(e (true (>= (index-of e "hk-error: Prelude.undefined") 0)))
(begin (hk-deep-force (hk-run "main = undefined")) false))
true)
(hk-test
"undefined: lazy — only fires when forced"
(hk-deep-force (hk-run "main = if True then 42 else undefined"))
42)
(hk-test
"head []: raises Prelude.head: empty list"
(guard
(e (true (>= (index-of e "Prelude.head: empty list") 0)))
(begin (hk-deep-force (hk-run "main = head []")) false))
true)
(hk-test
"tail []: raises Prelude.tail: empty list"
(guard
(e (true (>= (index-of e "Prelude.tail: empty list") 0)))
(begin (hk-deep-force (hk-run "main = tail []")) false))
true)
;; ── not / id built-ins ──
(hk-test
"fromJust Nothing: raises Maybe.fromJust: Nothing"
(guard
(e (true (>= (index-of e "Maybe.fromJust: Nothing") 0)))
(begin (hk-deep-force (hk-run "main = fromJust Nothing")) false))
true)
(hk-test
"fromJust (Just 5) = 5"
(hk-deep-force (hk-run "main = fromJust (Just 5)"))
5)
(hk-test
"head [42] = 42 (still works for non-empty)"
(hk-deep-force (hk-run "main = head [42]"))
42)
(hk-test-error
"hk-test-error helper: catches matching error"
(fn () (hk-deep-force (hk-run "main = error \"boom\"")))
"hk-error: boom")
(hk-test-error
"hk-test-error helper: catches head [] error"
(fn () (hk-deep-force (hk-run "main = head []")))
"Prelude.head: empty list")
(hk-test
"second arg never forced"
(hk-eval-expr-source
"(\\x y -> x) 1 (error \"never\")")
(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")
(hk-eval-expr-source "(\\x y -> y) (error \"never\") 99")
99)
(hk-test
@@ -251,9 +317,7 @@
(hk-test
"lazy: const drops its second argument"
(hk-prog-val
"const x y = x\nresult = const 5 (error \"boom\")"
"result")
(hk-prog-val "const x y = x\nresult = const 5 (error \"boom\")" "result")
5)
(hk-test
@@ -270,9 +334,10 @@
"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}

105
lib/haskell/tests/exceptions.sx Normal file
View File

@@ -0,0 +1,105 @@
;; Phase 16 — Exception handling unit tests.
(hk-test
"catch — success path returns the action result"
(hk-deep-force
(hk-run
"main = catch (return 42) (\\(SomeException m) -> return 0)"))
(list "IO" 42))
(hk-test
"catch — error caught, handler receives message"
(hk-deep-force
(hk-run
"main = catch (error \"boom\") (\\(SomeException m) -> return m)"))
(list "IO" "boom"))
(hk-test
"try — success returns Right v"
(hk-deep-force
(hk-run "main = try (return 42)"))
(list "IO" (list "Right" 42)))
(hk-test
"try — error returns Left (SomeException msg)"
(hk-deep-force
(hk-run "main = try (error \"oops\")"))
(list "IO" (list "Left" (list "SomeException" "oops"))))
(hk-test
"handle — flip catch — caught error message"
(hk-deep-force
(hk-run
"main = handle (\\(SomeException m) -> return m) (error \"hot\")"))
(list "IO" "hot"))
(hk-test
"throwIO + catch — handler sees the SomeException"
(hk-deep-force
(hk-run
"main = catch (throwIO (SomeException \"bang\")) (\\(SomeException m) -> return m)"))
(list "IO" "bang"))
(hk-test
"throwIO + try — Left side"
(hk-deep-force
(hk-run
"main = try (throwIO (SomeException \"x\"))"))
(list "IO" (list "Left" (list "SomeException" "x"))))
(hk-test
"evaluate — pure value returns IO v"
(hk-deep-force
(hk-run "main = evaluate (1 + 2 + 3)"))
(list "IO" 6))
(hk-test
"evaluate — error surfaces as catchable exception"
(hk-deep-force
(hk-run
"main = catch (evaluate (error \"deep\")) (\\(SomeException m) -> return m)"))
(list "IO" "deep"))
(hk-test
"nested catch — inner handler runs first"
(hk-deep-force
(hk-run
"main = catch (catch (error \"inner\") (\\(SomeException m) -> error (m ++ \"-rethrown\"))) (\\(SomeException m) -> return m)"))
(list "IO" "inner-rethrown"))
(hk-test
"catch chain — handler can succeed inside IO"
(hk-deep-force
(hk-run
"main = do { x <- catch (error \"e1\") (\\(SomeException m) -> return 100); return (x + 1) }"))
(list "IO" 101))
(hk-test
"try then bind on Right"
(hk-deep-force
(hk-run
"branch (Right v) = return (v * 2)
branch (Left _) = return 0
main = do { r <- try (return 21); branch r }"))
(list "IO" 42))
(hk-test
"try then bind on Left"
(hk-deep-force
(hk-run
"branch (Right _) = return \"ok\"
branch (Left (SomeException m)) = return m
main = do { r <- try (error \"failed\"); branch r }"))
(list "IO" "failed"))
(hk-test
"catch — handler can use closed-over IORef"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef
main = do
r <- IORef.newIORef 0
catch (error \"x\") (\\(SomeException m) -> IORef.writeIORef r 7)
v <- IORef.readIORef r
return v"))
(list "IO" 7))

31
lib/haskell/tests/instance-where.sx Normal file
View File

@@ -0,0 +1,31 @@
;; instance-where.sx — Phase 13: where-clauses inside instance bodies.
(hk-test
"instance method body with where-helper (Bool)"
(hk-deep-force
(hk-run
"class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet True"))
"yes")
(hk-test
"instance method body with where-helper (False branch)"
(hk-deep-force
(hk-run
"class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet False"))
"no")
(hk-test
"instance method body with where-binding referenced multiple times"
(hk-deep-force
(hk-run
"class Twice a where\n twice :: a -> Int\ninstance Twice Int where\n twice x = h + h\n where h = x + 1\nmain = twice 5"))
12)
(hk-test
"instance method body with multi-binding where"
(hk-deep-force
(hk-run
"class Calc a where\n calc :: a -> Int\ninstance Calc Int where\n calc x = a + b\n where a = x * 2\n b = x + 1\nmain = calc 3"))
10)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

11
lib/haskell/tests/io-input.sx
View File

@@ -64,12 +64,11 @@
(hk-test
"readFile error on missing file"
(guard
(e (true (>= (index-of e "file not found") 0)))
(begin
(set! hk-vfs (dict))
(hk-run-io "main = readFile \"no.txt\" >>= putStrLn")
false))
(begin
(set! hk-vfs (dict))
(let
((lines (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")))
(>= (index-of (str lines) "file not found") 0)))
true)
(hk-test

94
lib/haskell/tests/ioref.sx Normal file
View File

@@ -0,0 +1,94 @@
;; Phase 15 — IORef unit tests.
(hk-test
"newIORef + readIORef returns initial value"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 42; v <- IORef.readIORef r; return v }"))
(list "IO" 42))
(hk-test
"writeIORef updates the cell"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 99; v <- IORef.readIORef r; return v }"))
(list "IO" 99))
(hk-test
"writeIORef returns IO ()"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 1 }"))
(list "IO" (list "Tuple")))
(hk-test
"modifyIORef applies a function"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 5; IORef.modifyIORef r (\\x -> x * 2); v <- IORef.readIORef r; return v }"))
(list "IO" 10))
(hk-test
"modifyIORef' (strict) applies a function"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 7; IORef.modifyIORef' r (\\x -> x + 3); v <- IORef.readIORef r; return v }"))
(list "IO" 10))
(hk-test
"two reads return the same value"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 11; a <- IORef.readIORef r; b <- IORef.readIORef r; return (a + b) }"))
(list "IO" 22))
(hk-test
"shared ref across do-steps: write then read"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 1; IORef.writeIORef r 2; IORef.writeIORef r 3; v <- IORef.readIORef r; return v }"))
(list "IO" 3))
(hk-test
"two refs are independent"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r1 <- IORef.newIORef 1; r2 <- IORef.newIORef 2; IORef.writeIORef r1 10; a <- IORef.readIORef r1; b <- IORef.readIORef r2; return (a + b) }"))
(list "IO" 12))
(hk-test
"string-valued IORef"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef \"hi\"; IORef.writeIORef r \"bye\"; v <- IORef.readIORef r; return v }"))
(list "IO" "bye"))
(hk-test
"list-valued IORef + cons"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef [1,2,3]; IORef.modifyIORef r (\\xs -> 0 : xs); v <- IORef.readIORef r; return v }"))
(list
"IO"
(list ":" 0 (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))))
(hk-test
"counter loop: increment N times"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nloop r 0 = return ()\nloop r n = do { IORef.modifyIORef r (\\x -> x + 1); loop r (n - 1) }\nmain = do { r <- IORef.newIORef 0; loop r 10; v <- IORef.readIORef r; return v }"))
(list "IO" 10))
(hk-test
"modifyIORef' inside a loop"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\ngo r 0 = return ()\ngo r n = do { IORef.modifyIORef' r (\\x -> x + n); go r (n - 1) }\nmain = do { r <- IORef.newIORef 0; go r 5; v <- IORef.readIORef r; return v }"))
(list "IO" 15))
(hk-test
"newIORef inside a function passed via parameter"
(hk-deep-force
(hk-run
"import qualified Data.IORef as IORef\nbump r = IORef.modifyIORef r (\\x -> x + 100)\nmain = do { r <- IORef.newIORef 1; bump r; v <- IORef.readIORef r; return v }"))
(list "IO" 101))

196
lib/haskell/tests/map.sx Normal file
View File

@@ -0,0 +1,196 @@
;; map.sx — Phase 11 Data.Map unit tests.
;;
;; Tests both the SX-level `hk-map-*` helpers and the Haskell-level
;; `Map.*` aliases bound by the import handler.
(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))))
;; ── SX-level (direct hk-map-*) ───────────────────────────────
(hk-test
"hk-map-empty: size 0, null true"
(list (hk-map-size hk-map-empty) (hk-map-null hk-map-empty))
(list 0 true))
(hk-test
"hk-map-singleton: lookup hit"
(let
((m (hk-map-singleton 5 "five")))
(list (hk-map-size m) (hk-map-lookup 5 m)))
(list 1 (list "Just" "five")))
(hk-test
"hk-map-insert: lookup hit on inserted"
(let ((m (hk-map-insert 1 "a" hk-map-empty))) (hk-map-lookup 1 m))
(list "Just" "a"))
(hk-test
"hk-map-lookup: miss returns Nothing"
(hk-map-lookup 99 (hk-map-singleton 1 "a"))
(list "Nothing"))
(hk-test
"hk-map-insert: overwrites existing key"
(let
((m (hk-map-insert 1 "second" (hk-map-insert 1 "first" hk-map-empty))))
(hk-map-lookup 1 m))
(list "Just" "second"))
(hk-test
"hk-map-delete: removes key"
(let
((m (hk-map-insert 2 "b" (hk-map-insert 1 "a" hk-map-empty))))
(let
((m2 (hk-map-delete 1 m)))
(list (hk-map-size m2) (hk-map-lookup 1 m2) (hk-map-lookup 2 m2))))
(list 1 (list "Nothing") (list "Just" "b")))
(hk-test
"hk-map-delete: missing key is no-op"
(let ((m (hk-map-singleton 1 "a"))) (hk-map-size (hk-map-delete 99 m)))
1)
(hk-test
"hk-map-member: true on existing"
(hk-map-member 1 (hk-map-singleton 1 "a"))
true)
(hk-test
"hk-map-member: false on missing"
(hk-map-member 99 (hk-map-singleton 1 "a"))
false)
(hk-test
"hk-map-from-list: builds map; keys sorted"
(hk-map-keys
(hk-map-from-list
(list (list 3 "c") (list 1 "a") (list 5 "e") (list 2 "b"))))
(list 1 2 3 5))
(hk-test
"hk-map-from-list: duplicates — last wins"
(hk-map-lookup
1
(hk-map-from-list (list (list 1 "first") (list 1 "second"))))
(list "Just" "second"))
(hk-test
"hk-map-to-asc-list: ordered traversal"
(hk-map-to-asc-list
(hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
(list (list 1 "a") (list 2 "b") (list 3 "c")))
(hk-test
"hk-map-elems: in key order"
(hk-map-elems
(hk-map-from-list (list (list 3 30) (list 1 10) (list 2 20))))
(list 10 20 30))
(hk-test
"hk-map-union-with: combines duplicates"
(hk-map-to-asc-list
(hk-map-union-with
(fn (a b) (str a "+" b))
(hk-map-from-list (list (list 1 "a") (list 2 "b")))
(hk-map-from-list (list (list 2 "B") (list 3 "c")))))
(list (list 1 "a") (list 2 "b+B") (list 3 "c")))
(hk-test
"hk-map-intersection-with: keeps shared keys"
(hk-map-to-asc-list
(hk-map-intersection-with
+
(hk-map-from-list (list (list 1 10) (list 2 20)))
(hk-map-from-list (list (list 2 200) (list 3 30)))))
(list (list 2 220)))
(hk-test
"hk-map-difference: drops m2 keys"
(hk-map-keys
(hk-map-difference
(hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))
(hk-map-from-list (list (list 2 "x")))))
(list 1 3))
(hk-test
"hk-map-foldl-with-key: in-order accumulate"
(hk-map-foldl-with-key
(fn (acc k v) (str acc k v))
""
(hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
"1a2b3c")
(hk-test
"hk-map-map-with-key: transforms values"
(hk-map-to-asc-list
(hk-map-map-with-key
(fn (k v) (* k v))
(hk-map-from-list (list (list 2 10) (list 3 100)))))
(list (list 2 20) (list 3 300)))
(hk-test
"hk-map-filter-with-key: keeps matches"
(hk-map-keys
(hk-map-filter-with-key
(fn (k v) (> k 1))
(hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))))
(list 2 3))
(hk-test
"hk-map-adjust: applies f to existing"
(hk-map-lookup
1
(hk-map-adjust (fn (v) (* v 10)) 1 (hk-map-singleton 1 5)))
(list "Just" 50))
(hk-test
"hk-map-insert-with: combines on existing"
(hk-map-lookup 1 (hk-map-insert-with + 1 5 (hk-map-singleton 1 10)))
(list "Just" 15))
(hk-test
"hk-map-alter: Nothing → delete"
(hk-map-size
(hk-map-alter
(fn (mv) (list "Nothing"))
1
(hk-map-from-list (list (list 1 "a") (list 2 "b")))))
1)
;; ── Haskell-level (Map.*) via import wiring ─────────────────
(hk-test
"Map.size after Map.insert chain"
(hk-deep-force
(hk-run
"import qualified Data.Map as Map\nmain = Map.size (Map.insert 2 \"b\" (Map.insert 1 \"a\" Map.empty))"))
2)
(hk-test
"Map.lookup hit"
(hk-deep-force
(hk-run
"import qualified Data.Map as Map\nmain = Map.lookup 1 (Map.insert 1 \"a\" Map.empty)"))
(list "Just" "a"))
(hk-test
"Map.lookup miss"
(hk-deep-force
(hk-run
"import qualified Data.Map as Map\nmain = Map.lookup 99 (Map.insert 1 \"a\" Map.empty)"))
(list "Nothing"))
(hk-test
"Map.member true"
(hk-deep-force
(hk-run
"import qualified Data.Map as Map\nmain = Map.member 5 (Map.insert 5 \"x\" Map.empty)"))
(list "True"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

180
lib/haskell/tests/numerics.sx Normal file
View File

@@ -0,0 +1,180 @@
;; numerics.sx — Phase 10 numeric tower verification.
;;
;; Practical integer-precision limit in Haskell-on-SX:
;; • Raw SX `(* a b)` stays exact up to ±2^62 (≈ 4.6e18, OCaml int63).
;; • BUT the Haskell tokenizer/parser parses an integer literal as a float
;; once it exceeds 2^53 (≈ 9.007e15). Once any operand is a float, the
;; binop result is a float (and decimal-precision is lost past 2^53).
;; • Therefore: programs that stay below ~9e15 are exact; larger literals
;; or accumulated products silently become floats. `factorial 18` is the
;; last factorial that stays exact (6.4e15); `factorial 19` already floats.
;;
;; In Haskell terms, `Int` and `Integer` both currently map to SX number, so
;; we don't yet support arbitrary-precision Integer. Documented; unbounded
;; Integer is out of scope for Phase 10 — see Phase 11+ if it becomes needed.
(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))))
(hk-test
"factorial 10 = 3628800 (small, exact)"
(hk-deep-force
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 10"))
3628800)
(hk-test
"factorial 15 = 1307674368000 (mid-range, exact)"
(hk-deep-force
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 15"))
1307674368000)
(hk-test
"factorial 18 = 6402373705728000 (last exact factorial)"
(hk-deep-force
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 18"))
6402373705728000)
(hk-test
"1000000 * 1000000 = 10^12 (exact)"
(hk-deep-force (hk-run "main = 1000000 * 1000000"))
1000000000000)
(hk-test
"1000000000 * 1000000000 = 10^18 (exact, at boundary)"
(hk-deep-force (hk-run "main = 1000000000 * 1000000000"))
1e+18)
(hk-test
"2^62 boundary: pow accumulates exactly"
(hk-deep-force
(hk-run "pow b 0 = 1\npow b n = b * pow b (n - 1)\nmain = pow 2 62"))
4.6116860184273879e+18)
(hk-test
"show factorial 12 = 479001600 (whole, fits in 32-bit)"
(hk-deep-force
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = show (fact 12)"))
"479001600")
(hk-test
"negate large positive — preserves magnitude"
(hk-deep-force (hk-run "main = negate 1000000000000000000"))
-1e+18)
(hk-test
"abs negative large — preserves magnitude"
(hk-deep-force (hk-run "main = abs (negate 1000000000000000000)"))
1e+18)
(hk-test
"div on large ints"
(hk-deep-force (hk-run "main = div 1000000000000000000 1000000000"))
1000000000)
(hk-test
"fromIntegral 42 = 42 (identity in our runtime)"
(hk-deep-force (hk-run "main = fromIntegral 42"))
42)
(hk-test
"fromIntegral preserves negative"
(hk-deep-force (hk-run "main = fromIntegral (negate 7)"))
-7)
(hk-test
"fromIntegral round-trips through arithmetic"
(hk-deep-force (hk-run "main = fromIntegral 5 + fromIntegral 3"))
8)
(hk-test
"fromIntegral in a program (mixing with map)"
(hk-as-list (hk-deep-force (hk-run "main = map fromIntegral [1,2,3]")))
(list 1 2 3))
(hk-test
"toInteger 100 = 100 (identity)"
(hk-deep-force (hk-run "main = toInteger 100"))
100)
(hk-test
"fromInteger 7 = 7 (identity)"
(hk-deep-force (hk-run "main = fromInteger 7"))
7)
(hk-test
"toInteger / fromInteger round-trip"
(hk-deep-force (hk-run "main = fromInteger (toInteger 42)"))
42)
(hk-test
"toInteger preserves negative"
(hk-deep-force (hk-run "main = toInteger (negate 13)"))
-13)
(hk-test
"show 3.14 = 3.14"
(hk-deep-force (hk-run "main = show 3.14"))
"3.14")
(hk-test
"show 1.0e10 — whole-valued float renders as decimal (int/float ambiguity)"
(hk-deep-force (hk-run "main = show 1.0e10"))
"10000000000")
(hk-test
"show 0.001 uses scientific form (sub-0.1)"
(hk-deep-force (hk-run "main = show 0.001"))
"1.0e-3")
(hk-test
"show negative float"
(hk-deep-force (hk-run "main = show (negate 3.14)"))
"-3.14")
(hk-test "sqrt 16 = 4" (hk-deep-force (hk-run "main = sqrt 16")) 4)
(hk-test "floor 3.7 = 3" (hk-deep-force (hk-run "main = floor 3.7")) 3)
(hk-test "ceiling 3.2 = 4" (hk-deep-force (hk-run "main = ceiling 3.2")) 4)
(hk-test
"ceiling on whole = self"
(hk-deep-force (hk-run "main = ceiling 4"))
4)
(hk-test "round 2.6 = 3" (hk-deep-force (hk-run "main = round 2.6")) 3)
(hk-test
"truncate -3.7 = -3"
(hk-deep-force (hk-run "main = truncate (negate 3.7)"))
-3)
(hk-test "recip 4.0 = 0.25" (hk-deep-force (hk-run "main = recip 4.0")) 0.25)
(hk-test "1.0 / 4.0 = 0.25" (hk-deep-force (hk-run "main = 1.0 / 4.0")) 0.25)
(hk-test
"fromRational 0.5 = 0.5 (identity)"
(hk-deep-force (hk-run "main = fromRational 0.5"))
0.5)
(hk-test "pi ≈ 3.14159" (hk-deep-force (hk-run "main = pi")) 3.14159)
(hk-test "exp 0 = 1" (hk-deep-force (hk-run "main = exp 0")) 1)
(hk-test "sin 0 = 0" (hk-deep-force (hk-run "main = sin 0")) 0)
(hk-test "cos 0 = 1" (hk-deep-force (hk-run "main = cos 0")) 1)
(hk-test "2 ** 10 = 1024" (hk-deep-force (hk-run "main = 2 ** 10")) 1024)
(hk-test "log (exp 5) ≈ 5" (hk-deep-force (hk-run "main = log (exp 5)")) 5)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

81
lib/haskell/tests/program-accumulate.sx Normal file
View File

@@ -0,0 +1,81 @@
;; accumulate.hs — accumulate results into an IORef [Int] (Phase 15 conformance).
(define
hk-accumulate-source
"import qualified Data.IORef as IORef\n\npush :: IORef [Int] -> Int -> IO ()\npush r x = IORef.modifyIORef r (\\xs -> x : xs)\n\npushAll :: IORef [Int] -> [Int] -> IO ()\npushAll r [] = return ()\npushAll r (x:xs) = do\n push r x\n pushAll r xs\n\nreadReversed :: IORef [Int] -> IO [Int]\nreadReversed r = do\n xs <- IORef.readIORef r\n return (reverse xs)\n\ndoubleEach :: IORef [Int] -> [Int] -> IO ()\ndoubleEach r [] = return ()\ndoubleEach r (x:xs) = do\n push r (x * 2)\n doubleEach r xs\n\nsumIntoRef :: IORef Int -> [Int] -> IO ()\nsumIntoRef r [] = return ()\nsumIntoRef r (x:xs) = do\n IORef.modifyIORef r (\\acc -> acc + x)\n sumIntoRef r xs\n\n")
(hk-test
"accumulate.hs — push three then read length"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"main = do { r <- IORef.newIORef []; push r 1; push r 2; push r 3; xs <- IORef.readIORef r; return (length xs) }")))
(list "IO" 3))
(hk-test
"accumulate.hs — pushAll preserves reverse order"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"main = do { r <- IORef.newIORef []; pushAll r [1,2,3,4]; xs <- IORef.readIORef r; return xs }")))
(list
"IO"
(list ":" 4 (list ":" 3 (list ":" 2 (list ":" 1 (list "[]")))))))
(hk-test
"accumulate.hs — readReversed gives original order"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"main = do { r <- IORef.newIORef []; pushAll r [10,20,30]; readReversed r }")))
(list "IO" (list ":" 10 (list ":" 20 (list ":" 30 (list "[]"))))))
(hk-test
"accumulate.hs — doubleEach maps then accumulates"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"main = do { r <- IORef.newIORef []; doubleEach r [1,2,3]; readReversed r }")))
(list "IO" (list ":" 2 (list ":" 4 (list ":" 6 (list "[]"))))))
(hk-test
"accumulate.hs — sum into Int IORef"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"main = do { r <- IORef.newIORef 0; sumIntoRef r [1,2,3,4,5]; v <- IORef.readIORef r; return v }")))
(list "IO" 15))
(hk-test
"accumulate.hs — empty list leaves ref untouched"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"main = do { r <- IORef.newIORef [99]; pushAll r []; xs <- IORef.readIORef r; return xs }")))
(list "IO" (list ":" 99 (list "[]"))))
(hk-test
"accumulate.hs — pushAll then sumIntoRef on the same input"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"main = do { r <- IORef.newIORef 0; sumIntoRef r [10,20,30,40]; v <- IORef.readIORef r; return v }")))
(list "IO" 100))
(hk-test
"accumulate.hs — accumulate results from a recursive helper"
(hk-deep-force
(hk-run
(str
hk-accumulate-source
"squaresUpTo r 0 = return ()\nsquaresUpTo r n = do { push r (n * n); squaresUpTo r (n - 1) }\nmain = do { r <- IORef.newIORef []; squaresUpTo r 4; readReversed r }")))
(list
"IO"
(list ":" 16 (list ":" 9 (list ":" 4 (list ":" 1 (list "[]")))))))

80
lib/haskell/tests/program-caesar.sx Normal file
View File

@@ -0,0 +1,80 @@
;; caesar.hs — Caesar cipher.
;; Source: https://rosettacode.org/wiki/Caesar_cipher#Haskell (adapted).
;;
;; Exercises chr, ord, isUpper, isLower, mod, string pattern matching
;; (x:xs) over a String (which is now a [Char] string view), and map
;; from the Phase 7 string=[Char] foundation.
(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-caesar-source
"shift n c = if isUpper c\n then chr (mod ((ord c) - 65 + n) 26 + 65)\n else if isLower c\n then chr (mod ((ord c) - 97 + n) 26 + 97)\n else chr c\n\ncaesarRec n [] = []\ncaesarRec n (x:xs) = shift n x : caesarRec n xs\n\ncaesarMap n s = map (shift n) s\n")
(hk-test
"caesar.hs — caesarRec 3 \"ABC\" = DEF"
(hk-as-list
(hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"ABC\"\n") "r"))
(list "D" "E" "F"))
(hk-test
"caesar.hs — caesarRec 13 \"Hello\" = Uryyb"
(hk-as-list
(hk-prog-val (str hk-caesar-source "r = caesarRec 13 \"Hello\"\n") "r"))
(list "U" "r" "y" "y" "b"))
(hk-test
"caesar.hs — caesarRec 1 \"AZ\" wraps to BA"
(hk-as-list
(hk-prog-val (str hk-caesar-source "r = caesarRec 1 \"AZ\"\n") "r"))
(list "B" "A"))
(hk-test
"caesar.hs — caesarRec 0 \"World\" identity"
(hk-as-list
(hk-prog-val (str hk-caesar-source "r = caesarRec 0 \"World\"\n") "r"))
(list "W" "o" "r" "l" "d"))
(hk-test
"caesar.hs — caesarRec preserves punctuation"
(hk-as-list
(hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"Hi!\"\n") "r"))
(list "K" "l" "!"))
(hk-test
"caesar.hs — caesarMap 3 \"abc\" via map"
(hk-as-list
(hk-prog-val (str hk-caesar-source "r = caesarMap 3 \"abc\"\n") "r"))
(list "d" "e" "f"))
(hk-test
"caesar.hs — caesarMap 13 round-trips with caesarMap 13"
(hk-as-list
(hk-prog-val
(str
hk-caesar-source
"r = caesarMap 13 (foldr (\\c acc -> c : acc) [] (caesarMap 13 \"Hello\"))\n")
"r"))
(list "H" "e" "l" "l" "o"))
(hk-test
"caesar.hs — caesarRec 25 \"AB\" = ZA"
(hk-as-list
(hk-prog-val (str hk-caesar-source "r = caesarRec 25 \"AB\"\n") "r"))
(list "Z" "A"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

63
lib/haskell/tests/program-config.sx Normal file
View File

@@ -0,0 +1,63 @@
;; config.hs — multi-field config record; partial update; defaultConfig
;; constant.
;;
;; Exercises Phase 14: 4-field record, defaultConfig as a CAF, partial
;; updates that change one or two fields, accessors over derived configs.
(define
hk-config-source
"data Config = Config { host :: String, port :: Int, retries :: Int, debug :: Bool } deriving (Show)\n\ndefaultConfig = Config { host = \"localhost\", port = 8080, retries = 3, debug = False }\n\ndevConfig = defaultConfig { debug = True }\nremoteConfig = defaultConfig { host = \"api.example.com\", port = 443 }\n")
(hk-test
"config.hs — defaultConfig host"
(hk-deep-force (hk-run (str hk-config-source "main = host defaultConfig")))
"localhost")
(hk-test
"config.hs — defaultConfig port"
(hk-deep-force (hk-run (str hk-config-source "main = port defaultConfig")))
8080)
(hk-test
"config.hs — defaultConfig retries"
(hk-deep-force
(hk-run (str hk-config-source "main = retries defaultConfig")))
3)
(hk-test
"config.hs — devConfig flips debug"
(hk-deep-force (hk-run (str hk-config-source "main = debug devConfig")))
(list "True"))
(hk-test
"config.hs — devConfig preserves host"
(hk-deep-force (hk-run (str hk-config-source "main = host devConfig")))
"localhost")
(hk-test
"config.hs — devConfig preserves port"
(hk-deep-force (hk-run (str hk-config-source "main = port devConfig")))
8080)
(hk-test
"config.hs — remoteConfig new host"
(hk-deep-force (hk-run (str hk-config-source "main = host remoteConfig")))
"api.example.com")
(hk-test
"config.hs — remoteConfig new port"
(hk-deep-force (hk-run (str hk-config-source "main = port remoteConfig")))
443)
(hk-test
"config.hs — remoteConfig preserves retries"
(hk-deep-force
(hk-run (str hk-config-source "main = retries remoteConfig")))
3)
(hk-test
"config.hs — remoteConfig preserves debug"
(hk-deep-force (hk-run (str hk-config-source "main = debug remoteConfig")))
(list "False"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

66
lib/haskell/tests/program-counter.sx Normal file
View File

@@ -0,0 +1,66 @@
;; counter.hs — IORef-backed mutable counter (Phase 15 conformance).
(define
hk-counter-source
"import qualified Data.IORef as IORef\n\ncount :: IORef Int -> Int -> IO ()\ncount r 0 = return ()\ncount r n = do\n IORef.modifyIORef r (\\x -> x + 1)\n count r (n - 1)\n\ncountBy :: IORef Int -> Int -> Int -> IO ()\ncountBy r step 0 = return ()\ncountBy r step n = do\n IORef.modifyIORef r (\\x -> x + step)\n countBy r step (n - 1)\n\nnewCounter :: Int -> IO (IORef Int)\nnewCounter v = IORef.newIORef v\n\nbumpAndRead :: IORef Int -> IO Int\nbumpAndRead r = do\n IORef.modifyIORef r (\\x -> x + 1)\n IORef.readIORef r\n\n")
(hk-test
"counter.hs — start at 0, count 5 ⇒ 5"
(hk-deep-force
(hk-run
(str
hk-counter-source
"main = do { r <- newCounter 0; count r 5; v <- IORef.readIORef r; return v }")))
(list "IO" 5))
(hk-test
"counter.hs — start at 100, count 10 ⇒ 110"
(hk-deep-force
(hk-run
(str
hk-counter-source
"main = do { r <- newCounter 100; count r 10; v <- IORef.readIORef r; return v }")))
(list "IO" 110))
(hk-test
"counter.hs — countBy step 5, n 4 ⇒ 20"
(hk-deep-force
(hk-run
(str
hk-counter-source
"main = do { r <- newCounter 0; countBy r 5 4; v <- IORef.readIORef r; return v }")))
(list "IO" 20))
(hk-test
"counter.hs — bumpAndRead returns updated value"
(hk-deep-force
(hk-run
(str hk-counter-source "main = do { r <- newCounter 41; bumpAndRead r }")))
(list "IO" 42))
(hk-test
"counter.hs — count then countBy compose"
(hk-deep-force
(hk-run
(str
hk-counter-source
"main = do { r <- newCounter 0; count r 3; countBy r 10 2; v <- IORef.readIORef r; return v }")))
(list "IO" 23))
(hk-test
"counter.hs — two independent counters"
(hk-deep-force
(hk-run
(str
hk-counter-source
"main = do { a <- newCounter 0; b <- newCounter 0; count a 7; countBy b 100 2; va <- IORef.readIORef a; vb <- IORef.readIORef b; return (va + vb) }")))
(list "IO" 207))
(hk-test
"counter.hs — modifyIORef' (strict) variant"
(hk-deep-force
(hk-run
(str
hk-counter-source
"tick r 0 = return ()\ntick r n = do { IORef.modifyIORef' r (\\x -> x + 1); tick r (n - 1) }\nmain = do { r <- newCounter 0; tick r 50; v <- IORef.readIORef r; return v }")))
(list "IO" 50))

46
lib/haskell/tests/program-mapgraph.sx Normal file
View File

@@ -0,0 +1,46 @@
;; mapgraph.hs — adjacency-list using Data.Map (BFS-style traversal).
;;
;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
;; `Map.insert`, `Map.lookup`, `Map.findWithDefault`. Adjacency lists are
;; stored as `Map Int [Int]`; `neighbors` does a default-empty lookup.
(define
hk-mapgraph-source
"import qualified Data.Map as Map\n\nemptyG = Map.empty\n\naddEdge u v g = Map.insertWith add u [v] g\n where add new old = new ++ old\n\nbuild = addEdge 1 2 (addEdge 1 3 (addEdge 2 4 (addEdge 3 4 (addEdge 4 5 emptyG))))\n\nneighbors n g = Map.findWithDefault [] n g\n")
(hk-test
"mapgraph.hs — neighbors of 1"
(hk-deep-force
(hk-run (str hk-mapgraph-source "main = neighbors 1 build\n")))
(list ":" 2 (list ":" 3 (list "[]"))))
(hk-test
"mapgraph.hs — neighbors of 4"
(hk-deep-force
(hk-run (str hk-mapgraph-source "main = neighbors 4 build\n")))
(list ":" 5 (list "[]")))
(hk-test
"mapgraph.hs — neighbors of 5 (leaf, no entry) defaults to []"
(hk-deep-force
(hk-run (str hk-mapgraph-source "main = neighbors 5 build\n")))
(list "[]"))
(hk-test
"mapgraph.hs — neighbors of 99 (absent) defaults to []"
(hk-deep-force
(hk-run (str hk-mapgraph-source "main = neighbors 99 build\n")))
(list "[]"))
(hk-test
"mapgraph.hs — Map.member 1"
(hk-deep-force
(hk-run (str hk-mapgraph-source "main = Map.member 1 build\n")))
(list "True"))
(hk-test
"mapgraph.hs — Map.size = 4 source nodes"
(hk-deep-force (hk-run (str hk-mapgraph-source "main = Map.size build\n")))
4)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

49
lib/haskell/tests/program-newton.sx Normal file
View File

@@ -0,0 +1,49 @@
;; newton.hs — Newton's method for square root.
;; Source: classic numerical analysis exercise.
;;
;; Exercises Phase 10: `Float`, `abs`, `/`, iteration via `until`.
(define
hk-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-newton-source
"improve x guess = (guess + x / guess) / 2\n\ngoodEnough x guess = abs (guess * guess - x) < 0.0001\n\nnewtonSqrt x = newtonHelp x 1.0\n\nnewtonHelp x guess = if goodEnough x guess\n then guess\n else newtonHelp x (improve x guess)\n")
(hk-test
"newton.hs — newtonSqrt 4 ≈ 2"
(hk-prog-val
(str hk-newton-source "r = abs (newtonSqrt 4.0 - 2.0) < 0.001\n")
"r")
(list "True"))
(hk-test
"newton.hs — newtonSqrt 9 ≈ 3"
(hk-prog-val
(str hk-newton-source "r = abs (newtonSqrt 9.0 - 3.0) < 0.001\n")
"r")
(list "True"))
(hk-test
"newton.hs — newtonSqrt 2 ≈ 1.41421"
(hk-prog-val
(str hk-newton-source "r = abs (newtonSqrt 2.0 - 1.41421) < 0.001\n")
"r")
(list "True"))
(hk-test
"newton.hs — improve converges (one step)"
(hk-prog-val (str hk-newton-source "r = improve 4.0 1.0\n") "r")
2.5)
(hk-test
"newton.hs — newtonSqrt 100 ≈ 10"
(hk-prog-val
(str hk-newton-source "r = abs (newtonSqrt 100.0 - 10.0) < 0.001\n")
"r")
(list "True"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

58
lib/haskell/tests/program-partial.sx Normal file
View File

@@ -0,0 +1,58 @@
;; partial.hs — exercises Phase 9 partial functions caught at the top level.
;;
;; Each program calls a partial function on bad input; hk-run-io catches the
;; raise and appends the error message to io-lines so tests can inspect.
(hk-test
"partial.hs — main = print (head [])"
(let
((lines (hk-run-io "main = print (head [])")))
(>= (index-of (str lines) "Prelude.head: empty list") 0))
true)
(hk-test
"partial.hs — main = print (tail [])"
(let
((lines (hk-run-io "main = print (tail [])")))
(>= (index-of (str lines) "Prelude.tail: empty list") 0))
true)
(hk-test
"partial.hs — main = print (fromJust Nothing)"
(let
((lines (hk-run-io "main = print (fromJust Nothing)")))
(>= (index-of (str lines) "Maybe.fromJust: Nothing") 0))
true)
(hk-test
"partial.hs — putStrLn before error preserves prior output"
(let
((lines (hk-run-io "main = do { putStrLn \"step 1\"; putStrLn (show (head [])); putStrLn \"never\" }")))
(and
(>= (index-of (str lines) "step 1") 0)
(>= (index-of (str lines) "Prelude.head: empty list") 0)
(= (index-of (str lines) "never") -1)))
true)
(hk-test
"partial.hs — undefined as IO action"
(let
((lines (hk-run-io "main = print undefined")))
(>= (index-of (str lines) "Prelude.undefined") 0))
true)
(hk-test
"partial.hs — catches error from a user-thrown error"
(let
((lines (hk-run-io "main = error \"boom from main\"")))
(>= (index-of (str lines) "boom from main") 0))
true)
;; Negative case: when no error is raised, io-lines doesn't contain
;; "Prelude" prefixes from our error path.
(hk-test
"partial.hs — happy path: head [42] succeeds, no error in output"
(hk-run-io "main = print (head [42])")
(list "42"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

51
lib/haskell/tests/program-person.sx Normal file
View File

@@ -0,0 +1,51 @@
;; person.hs — record type with accessors, update, deriving Show.
;;
;; Exercises Phase 14: data with record syntax, accessor functions,
;; record creation, record update, deriving Show on a record.
(define
hk-person-source
"data Person = Person { name :: String, age :: Int } deriving (Show)\n\nalice = Person { name = \"alice\", age = 30 }\nbob = Person { name = \"bob\", age = 25 }\n\nbirthday p = p { age = age p + 1 }\n")
(hk-test
"person.hs — alice's name"
(hk-deep-force (hk-run (str hk-person-source "main = name alice")))
"alice")
(hk-test
"person.hs — alice's age"
(hk-deep-force (hk-run (str hk-person-source "main = age alice")))
30)
(hk-test
"person.hs — birthday adds one year"
(hk-deep-force
(hk-run (str hk-person-source "main = age (birthday alice)")))
31)
(hk-test
"person.hs — birthday preserves name"
(hk-deep-force
(hk-run (str hk-person-source "main = name (birthday alice)")))
"alice")
(hk-test
"person.hs — show alice"
(hk-deep-force (hk-run (str hk-person-source "main = show alice")))
"Person \"alice\" 30")
(hk-test
"person.hs — bob has different name"
(hk-deep-force (hk-run (str hk-person-source "main = name bob")))
"bob")
(hk-test
"person.hs — pattern match in function"
(hk-deep-force
(hk-run
(str
hk-person-source
"greet (Person { name = n }) = \"Hi, \" ++ n\nmain = greet alice")))
"Hi, alice")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

83
lib/haskell/tests/program-runlength-str.sx Normal file
View File

@@ -0,0 +1,83 @@
;; runlength-str.hs — run-length encoding on a String.
;; Source: https://rosettacode.org/wiki/Run-length_encoding#Haskell (adapted).
;;
;; Exercises String pattern matching `(x:xs)`, `span` over a string view,
;; tuple construction `(Int, Char)`, character equality, and tuple-in-cons
;; patterns `((n, c) : rest)` — all enabled by Phase 7 string=[Char].
(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-rle-source
"encodeRL [] = []\nencodeRL (x:xs) = let (same, rest) = span eqX xs\n eqX y = y == x\n in (1 + length same, x) : encodeRL rest\n\nreplicateRL 0 _ = []\nreplicateRL n c = c : replicateRL (n - 1) c\n\ndecodeRL [] = []\ndecodeRL ((n, c) : rest) = replicateRL n c ++ decodeRL rest\n")
(hk-test
"rle.hs — encodeRL [] = []"
(hk-as-list (hk-prog-val (str hk-rle-source "r = encodeRL \"\"\n") "r"))
(list))
(hk-test
"rle.hs — length (encodeRL \"aabbbcc\") = 3"
(hk-prog-val (str hk-rle-source "r = length (encodeRL \"aabbbcc\")\n") "r")
3)
(hk-test
"rle.hs — map fst (encodeRL \"aabbbcc\") = [2,3,2]"
(hk-as-list
(hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"aabbbcc\")\n") "r"))
(list 2 3 2))
(hk-test
"rle.hs — map snd (encodeRL \"aabbbcc\") = [97,98,99]"
(hk-as-list
(hk-prog-val (str hk-rle-source "r = map snd (encodeRL \"aabbbcc\")\n") "r"))
(list 97 98 99))
(hk-test
"rle.hs — counts of encodeRL \"aabbbccddddee\" = [2,3,2,4,2]"
(hk-as-list
(hk-prog-val
(str hk-rle-source "r = map fst (encodeRL \"aabbbccddddee\")\n")
"r"))
(list 2 3 2 4 2))
(hk-test
"rle.hs — chars of encodeRL \"aabbbccddddee\" = [97,98,99,100,101]"
(hk-as-list
(hk-prog-val
(str hk-rle-source "r = map snd (encodeRL \"aabbbccddddee\")\n")
"r"))
(list 97 98 99 100 101))
(hk-test
"rle.hs — singleton encodeRL \"x\""
(hk-as-list
(hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"x\")\n") "r"))
(list 1))
(hk-test
"rle.hs — decodeRL round-trip preserves \"aabbbcc\""
(hk-as-list
(hk-prog-val (str hk-rle-source "r = decodeRL (encodeRL \"aabbbcc\")\n") "r"))
(list 97 97 98 98 98 99 99))
(hk-test
"rle.hs — replicateRL 4 65 = [65,65,65,65]"
(hk-as-list (hk-prog-val (str hk-rle-source "r = replicateRL 4 65\n") "r"))
(list 65 65 65 65))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

80
lib/haskell/tests/program-safediv.sx Normal file
View File

@@ -0,0 +1,80 @@
;; safediv.hs — safe division using catch (Phase 16 conformance).
(define
hk-safediv-source
"safeDiv :: Int -> Int -> IO Int
safeDiv _ 0 = throwIO (SomeException \"division by zero\")
safeDiv x y = return (x `div` y)
guarded :: Int -> Int -> IO Int
guarded x y = catch (safeDiv x y) (\\(SomeException _) -> return 0)
reason :: Int -> Int -> IO String
reason x y = catch (safeDiv x y `seq` return \"ok\")
(\\(SomeException m) -> return m)
bothBranches :: Int -> Int -> IO Int
bothBranches x y = do
v <- catch (safeDiv x y) (\\(SomeException _) -> return (-1))
return (v + 100)
")
(hk-test
"safediv.hs — divide by non-zero"
(hk-deep-force
(hk-run
(str hk-safediv-source "main = guarded 10 2")))
(list "IO" 5))
(hk-test
"safediv.hs — divide by zero returns 0"
(hk-deep-force
(hk-run
(str hk-safediv-source "main = guarded 10 0")))
(list "IO" 0))
(hk-test
"safediv.hs — divide by zero — reason captured"
(hk-deep-force
(hk-run
(str hk-safediv-source "main = catch (safeDiv 1 0) (\\(SomeException m) -> return 0) >> reason 1 0")))
(list "IO" "division by zero"))
(hk-test
"safediv.hs — bothBranches success path"
(hk-deep-force
(hk-run
(str hk-safediv-source "main = bothBranches 8 2")))
(list "IO" 104))
(hk-test
"safediv.hs — bothBranches failure path"
(hk-deep-force
(hk-run
(str hk-safediv-source "main = bothBranches 8 0")))
(list "IO" 99))
(hk-test
"safediv.hs — chained safeDiv with catch"
(hk-deep-force
(hk-run
(str hk-safediv-source
"main = do { a <- guarded 20 4; b <- guarded 7 0; return (a + b) }")))
(list "IO" 5))
(hk-test
"safediv.hs — try then bind through Either"
(hk-deep-force
(hk-run
(str hk-safediv-source
"main = do { r <- try (safeDiv 1 0); case r of { Right v -> return v; Left (SomeException m) -> return 999 } }")))
(list "IO" 999))
(hk-test
"safediv.hs — handle (flip catch)"
(hk-deep-force
(hk-run
(str hk-safediv-source
"main = handle (\\(SomeException _) -> return 0) (safeDiv 5 0)")))
(list "IO" 0))

61
lib/haskell/tests/program-setops.sx Normal file
View File

@@ -0,0 +1,61 @@
;; setops.hs — set union/intersection/difference on integer sets.
;;
;; Exercises Phase 12: `import qualified Data.Set as Set`, all three
;; combining operations + isSubsetOf.
(define
hk-setops-source
"import qualified Data.Set as Set\n\ns1 = Set.insert 1 (Set.insert 2 (Set.insert 3 Set.empty))\ns2 = Set.insert 3 (Set.insert 4 (Set.insert 5 Set.empty))\ns3 = Set.insert 1 (Set.insert 2 Set.empty)\n")
(hk-test
"setops.hs — union size = 5"
(hk-deep-force
(hk-run (str hk-setops-source "main = Set.size (Set.union s1 s2)\n")))
5)
(hk-test
"setops.hs — intersection size = 1"
(hk-deep-force
(hk-run
(str hk-setops-source "main = Set.size (Set.intersection s1 s2)\n")))
1)
(hk-test
"setops.hs — intersection contains 3"
(hk-deep-force
(hk-run
(str hk-setops-source "main = Set.member 3 (Set.intersection s1 s2)\n")))
(list "True"))
(hk-test
"setops.hs — difference s1 s2 size = 2"
(hk-deep-force
(hk-run (str hk-setops-source "main = Set.size (Set.difference s1 s2)\n")))
2)
(hk-test
"setops.hs — difference doesn't contain shared key"
(hk-deep-force
(hk-run
(str hk-setops-source "main = Set.member 3 (Set.difference s1 s2)\n")))
(list "False"))
(hk-test
"setops.hs — s3 is subset of s1"
(hk-deep-force
(hk-run (str hk-setops-source "main = Set.isSubsetOf s3 s1\n")))
(list "True"))
(hk-test
"setops.hs — s1 not subset of s3"
(hk-deep-force
(hk-run (str hk-setops-source "main = Set.isSubsetOf s1 s3\n")))
(list "False"))
(hk-test
"setops.hs — empty set is subset of anything"
(hk-deep-force
(hk-run (str hk-setops-source "main = Set.isSubsetOf Set.empty s1\n")))
(list "True"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

40
lib/haskell/tests/program-shapes.sx Normal file
View File

@@ -0,0 +1,40 @@
;; shapes.hs — class Area with a default perimeter, two instances
;; using where-local helpers.
;;
;; Exercises Phase 13: class default method (perimeter), instance
;; methods that use `where`-bindings.
(define
hk-shapes-source
"class Shape a where\n area :: a -> Int\n perimeter :: a -> Int\n perimeter x = quadrilateral x\n where quadrilateral y = 2 * (sideA y + sideB y)\n sideA z = 1\n sideB z = 1\n\ndata Square = Square Int\ndata Rect = Rect Int Int\n\ninstance Shape Square where\n area (Square s) = s * s\n perimeter (Square s) = 4 * s\n\ninstance Shape Rect where\n area (Rect w h) = w * h\n perimeter (Rect w h) = peri\n where peri = 2 * (w + h)\n")
(hk-test
"shapes.hs — area of Square 5 = 25"
(hk-deep-force (hk-run (str hk-shapes-source "main = area (Square 5)\n")))
25)
(hk-test
"shapes.hs — perimeter of Square 5 = 20"
(hk-deep-force
(hk-run (str hk-shapes-source "main = perimeter (Square 5)\n")))
20)
(hk-test
"shapes.hs — area of Rect 3 4 = 12"
(hk-deep-force (hk-run (str hk-shapes-source "main = area (Rect 3 4)\n")))
12)
(hk-test
"shapes.hs — perimeter of Rect 3 4 = 14 (via where-bound)"
(hk-deep-force
(hk-run (str hk-shapes-source "main = perimeter (Rect 3 4)\n")))
14)
(hk-test
"shapes.hs — Square sums area + perimeter"
(hk-deep-force
(hk-run
(str hk-shapes-source "main = area (Square 4) + perimeter (Square 4)\n")))
32)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

45
lib/haskell/tests/program-showadt.sx Normal file
View File

@@ -0,0 +1,45 @@
;; showadt.hs — `deriving (Show)` on a multi-constructor recursive ADT.
;; Source: classic exposition example, e.g. Real World Haskell ch.6.
;;
;; Exercises Phase 8: `deriving (Show)` on an ADT whose constructors recurse
;; into themselves; precedence-based paren wrapping for nested arguments;
;; `print` from the prelude (which is `putStrLn (show x)`).
(define
hk-showadt-source
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\n\nmain = do\n print (Lit 3)\n print (Add (Lit 1) (Lit 2))\n print (Mul (Lit 3) (Add (Lit 4) (Lit 5)))\n")
(hk-test
"showadt.hs — main prints three lines"
(hk-run-io hk-showadt-source)
(list "Lit 3" "Add (Lit 1) (Lit 2)" "Mul (Lit 3) (Add (Lit 4) (Lit 5))"))
(hk-test
"showadt.hs — show Lit 3"
(hk-deep-force
(hk-run
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit 3)"))
"Lit 3")
(hk-test
"showadt.hs — show Add wraps both args"
(hk-deep-force
(hk-run
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Add (Lit 1) (Lit 2))"))
"Add (Lit 1) (Lit 2)")
(hk-test
"showadt.hs — fully nested Mul of Adds"
(hk-deep-force
(hk-run
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4)))"))
"Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4))")
(hk-test
"showadt.hs — Lit with negative literal wraps int in parens"
(hk-deep-force
(hk-run
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit (negate 7))"))
"Lit (-7)")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

36
lib/haskell/tests/program-showio.sx Normal file
View File

@@ -0,0 +1,36 @@
;; showio.hs — `print` on various types inside a `do` block.
;;
;; Exercises Phase 8 `print x = putStrLn (show x)` and the IO monad's
;; statement sequencing. Each `print` produces one io-line.
(define
hk-showio-source
"main = do\n print 42\n print True\n print False\n print [1,2,3]\n print (1, 2)\n print (Just 5)\n print Nothing\n print \"hello\"\n")
(hk-test
"showio.hs — main produces 8 lines, all show-formatted"
(hk-run-io hk-showio-source)
(list "42" "True" "False" "[1,2,3]" "(1,2)" "Just 5" "Nothing" "\"hello\""))
(hk-test
"showio.hs — print Int alone"
(hk-run-io "main = print 42")
(list "42"))
(hk-test
"showio.hs — print list of Maybe"
(hk-run-io "main = print [Just 1, Nothing, Just 3]")
(list "[Just 1,Nothing,Just 3]"))
(hk-test
"showio.hs — print nested tuple"
(hk-run-io "main = print ((1, 2), (3, 4))")
(list "((1,2),(3,4))"))
(hk-test
"showio.hs — print derived ADT inside do"
(hk-run-io
"data Color = Red | Green | Blue deriving (Show)\nmain = do { print Red; print Green; print Blue }")
(list "Red" "Green" "Blue"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

45
lib/haskell/tests/program-statistics.sx Normal file
View File

@@ -0,0 +1,45 @@
;; statistics.hs — mean, variance, std-dev on a [Double].
;; Source: classic textbook example.
;;
;; Exercises Phase 10: `fromIntegral`, `/`, `sqrt`, list ops on `[Double]`.
(define
hk-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-stats-source
"mean xs = sum xs / fromIntegral (length xs)\n\nvariance xs = let m = mean xs\n sqDiff x = (x - m) * (x - m)\n in sum (map sqDiff xs) / fromIntegral (length xs)\n\nstdDev xs = sqrt (variance xs)\n")
(hk-test
"statistics.hs — mean [1,2,3,4,5] = 3"
(hk-prog-val (str hk-stats-source "r = mean [1.0,2.0,3.0,4.0,5.0]\n") "r")
3)
(hk-test
"statistics.hs — mean [10,20,30] = 20"
(hk-prog-val (str hk-stats-source "r = mean [10.0,20.0,30.0]\n") "r")
20)
(hk-test
"statistics.hs — variance [2,4,4,4,5,5,7,9] = 4"
(hk-prog-val
(str hk-stats-source "r = variance [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
"r")
4)
(hk-test
"statistics.hs — stdDev [2,4,4,4,5,5,7,9] = 2"
(hk-prog-val
(str hk-stats-source "r = stdDev [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
"r")
2)
(hk-test
"statistics.hs — variance of constant list = 0"
(hk-prog-val (str hk-stats-source "r = variance [5.0,5.0,5.0,5.0]\n") "r")
0)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

95
lib/haskell/tests/program-trycatch.sx Normal file
View File

@@ -0,0 +1,95 @@
;; trycatch.hs — try pattern: branch on Left/Right (Phase 16 conformance).
(define
hk-trycatch-source
"parseInt :: String -> IO Int
parseInt \"zero\" = return 0
parseInt \"one\" = return 1
parseInt \"two\" = return 2
parseInt s = throwIO (SomeException (\"unknown: \" ++ s))
describe :: Either SomeException Int -> String
describe (Right v) = \"got \" ++ show v
describe (Left (SomeException m)) = \"err: \" ++ m
trial :: String -> IO String
trial s = do
r <- try (parseInt s)
return (describe r)
run3 :: String -> String -> String -> IO [String]
run3 a b c = do
ra <- trial a
rb <- trial b
rc <- trial c
return [ra, rb, rc]
")
(hk-test
"trycatch.hs — Right branch"
(hk-deep-force
(hk-run
(str hk-trycatch-source "main = trial \"one\"")))
(list "IO" "got 1"))
(hk-test
"trycatch.hs — Left branch with message"
(hk-deep-force
(hk-run
(str hk-trycatch-source "main = trial \"banana\"")))
(list "IO" "err: unknown: banana"))
(hk-test
"trycatch.hs — chain over three inputs, all good"
(hk-deep-force
(hk-run
(str hk-trycatch-source "main = run3 \"zero\" \"one\" \"two\"")))
(list "IO"
(list ":" "got 0"
(list ":" "got 1"
(list ":" "got 2"
(list "[]"))))))
(hk-test
"trycatch.hs — chain over three inputs, mixed"
(hk-deep-force
(hk-run
(str hk-trycatch-source "main = run3 \"zero\" \"qux\" \"two\"")))
(list "IO"
(list ":" "got 0"
(list ":" "err: unknown: qux"
(list ":" "got 2"
(list "[]"))))))
(hk-test
"trycatch.hs — Left from throwIO carries message"
(hk-deep-force
(hk-run
(str hk-trycatch-source
"main = do { r <- try (throwIO (SomeException \"explicit\")); return (describe r) }")))
(list "IO" "err: explicit"))
(hk-test
"trycatch.hs — Right preserves the int"
(hk-deep-force
(hk-run
(str hk-trycatch-source
"main = do { r <- try (return 42); return (describe r) }")))
(list "IO" "got 42"))
(hk-test
"trycatch.hs — pattern-bind on Right inside do"
(hk-deep-force
(hk-run
(str hk-trycatch-source
"main = do { Right v <- try (parseInt \"two\"); return (v + 100) }")))
(list "IO" 102))
(hk-test
"trycatch.hs — handle alias on parseInt failure"
(hk-deep-force
(hk-run
(str hk-trycatch-source
"main = handle (\\(SomeException m) -> return (\"caught: \" ++ m)) (parseInt \"nope\" >>= (\\v -> return (show v)))")))
(list "IO" "caught: unknown: nope"))

35
lib/haskell/tests/program-uniquewords.sx Normal file
View File

@@ -0,0 +1,35 @@
;; uniquewords.hs — count unique words using Data.Set.
;;
;; Exercises Phase 12: `import qualified Data.Set as Set`, `Set.empty`,
;; `Set.insert`, `Set.size`, `foldl`.
(define
hk-uniquewords-source
"import qualified Data.Set as Set\n\naddWord s w = Set.insert w s\n\nuniqueWords ws = foldl addWord Set.empty ws\n\nresult = uniqueWords [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
(hk-test
"uniquewords.hs — unique count = 3"
(hk-deep-force
(hk-run (str hk-uniquewords-source "main = Set.size result\n")))
3)
(hk-test
"uniquewords.hs — \"the\" present"
(hk-deep-force
(hk-run (str hk-uniquewords-source "main = Set.member \"the\" result\n")))
(list "True"))
(hk-test
"uniquewords.hs — \"missing\" absent"
(hk-deep-force
(hk-run (str hk-uniquewords-source "main = Set.member \"missing\" result\n")))
(list "False"))
(hk-test
"uniquewords.hs — empty list yields empty set"
(hk-deep-force
(hk-run
"import qualified Data.Set as Set\nmain = Set.size (foldl (\\s w -> Set.insert w s) Set.empty [])"))
0)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

54
lib/haskell/tests/program-wordfreq.sx Normal file
View File

@@ -0,0 +1,54 @@
;; wordfreq.hs — word-frequency histogram using Data.Map.
;; Source: Rosetta Code "Word frequency" (Haskell entry, simplified).
;;
;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
;; `Map.insertWith`, `Map.lookup`, `Map.findWithDefault`, `foldl`.
(define
hk-wordfreq-source
"import qualified Data.Map as Map\n\ncountWord m w = Map.insertWith (+) w 1 m\n\nwordFreq xs = foldl countWord Map.empty xs\n\nresult = wordFreq [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
(hk-test
"wordfreq.hs — \"the\" counted 3 times"
(hk-deep-force
(hk-run (str hk-wordfreq-source "main = Map.lookup \"the\" result\n")))
(list "Just" 3))
(hk-test
"wordfreq.hs — \"cat\" counted 2 times"
(hk-deep-force
(hk-run (str hk-wordfreq-source "main = Map.lookup \"cat\" result\n")))
(list "Just" 2))
(hk-test
"wordfreq.hs — \"dog\" counted 1 time"
(hk-deep-force
(hk-run (str hk-wordfreq-source "main = Map.lookup \"dog\" result\n")))
(list "Just" 1))
(hk-test
"wordfreq.hs — \"missing\" not present"
(hk-deep-force
(hk-run (str hk-wordfreq-source "main = Map.lookup \"missing\" result\n")))
(list "Nothing"))
(hk-test
"wordfreq.hs — Map.size = 3 unique words"
(hk-deep-force (hk-run (str hk-wordfreq-source "main = Map.size result\n")))
3)
(hk-test
"wordfreq.hs — findWithDefault for missing returns 0"
(hk-deep-force
(hk-run
(str hk-wordfreq-source "main = Map.findWithDefault 0 \"absent\" result\n")))
0)
(hk-test
"wordfreq.hs — findWithDefault for present returns count"
(hk-deep-force
(hk-run
(str hk-wordfreq-source "main = Map.findWithDefault 0 \"the\" result\n")))
3)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

127
lib/haskell/tests/records.sx Normal file
View File

@@ -0,0 +1,127 @@
;; records.sx — Phase 14 record syntax tests.
(define
hk-person-source
"data Person = Person { name :: String, age :: Int }\n")
(define hk-pt-source "data Pt = Pt { x :: Int, y :: Int }\n")
;; ── Creation ────────────────────────────────────────────────
(hk-test
"creation: Person { name = \"a\", age = 1 } via accessor name"
(hk-deep-force
(hk-run
(str
hk-person-source
"main = name (Person { name = \"alice\", age = 30 })")))
"alice")
(hk-test
"creation: source order doesn't matter (age first)"
(hk-deep-force
(hk-run
(str hk-person-source "main = name (Person { age = 99, name = \"bob\" })")))
"bob")
(hk-test
"creation: age accessor returns the right field"
(hk-deep-force
(hk-run
(str hk-person-source "main = age (Person { age = 99, name = \"bob\" })")))
99)
;; ── Accessors ──────────────────────────────────────────────
(hk-test
"accessor: x of Pt"
(hk-deep-force
(hk-run (str hk-pt-source "main = x (Pt { x = 7, y = 99 })")))
7)
(hk-test
"accessor: y of Pt"
(hk-deep-force
(hk-run (str hk-pt-source "main = y (Pt { x = 7, y = 99 })")))
99)
;; ── Update — single field ──────────────────────────────────
(hk-test
"update one field: age changes"
(hk-deep-force
(hk-run
(str
hk-person-source
"alice = Person { name = \"alice\", age = 30 }\nmain = age (alice { age = 31 })")))
31)
(hk-test
"update one field: name preserved"
(hk-deep-force
(hk-run
(str
hk-person-source
"alice = Person { name = \"alice\", age = 30 }\nmain = name (alice { age = 31 })")))
"alice")
;; ── Update — two fields ────────────────────────────────────
(hk-test
"update two fields: both changed"
(hk-deep-force
(hk-run
(str
hk-person-source
"alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = age bob")))
50)
(hk-test
"update two fields: name takes new value"
(hk-deep-force
(hk-run
(str
hk-person-source
"alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = name bob")))
"bob")
;; ── Record patterns ────────────────────────────────────────
(hk-test
"case-alt record pattern: Pt { x = a }"
(hk-deep-force
(hk-run
(str
hk-pt-source
"getX p = case p of Pt { x = a } -> a\nmain = getX (Pt { x = 7, y = 99 })")))
7)
(hk-test
"case-alt record pattern: multi-field bind"
(hk-deep-force
(hk-run
(str
hk-pt-source
"sumPt p = case p of Pt { x = a, y = b } -> a + b\nmain = sumPt (Pt { x = 3, y = 4 })")))
7)
(hk-test
"fun-LHS record pattern"
(hk-deep-force
(hk-run
(str
hk-person-source
"getName (Person { name = n }) = n\nmain = getName (Person { name = \"alice\", age = 30 })")))
"alice")
;; ── deriving Show on a record ───────────────────────────────
(hk-test
"deriving Show on a record produces positional output"
(hk-deep-force
(hk-run
"data Person = Person { name :: String, age :: Int } deriving (Show)\nmain = show (Person { name = \"alice\", age = 30 })"))
"Person \"alice\" 30")
(hk-test
"deriving Show on Pt"
(hk-deep-force
(hk-run
"data Pt = Pt { x :: Int, y :: Int } deriving (Show)\nmain = show (Pt { x = 3, y = 4 })"))
"Pt 3 4")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

119
lib/haskell/tests/set.sx Normal file
View File

@@ -0,0 +1,119 @@
;; set.sx — Phase 12 Data.Set unit tests.
;; ── SX-level (direct hk-set-*) ───────────────────────────────
(hk-test
"hk-set-empty: size 0 + null"
(list (hk-set-size hk-set-empty) (hk-set-null hk-set-empty))
(list 0 true))
(hk-test
"hk-set-singleton: member yes"
(let
((s (hk-set-singleton 5)))
(list (hk-set-size s) (hk-set-member 5 s) (hk-set-member 99 s)))
(list 1 true false))
(hk-test
"hk-set-insert: idempotent"
(let
((s (hk-set-insert 1 (hk-set-insert 1 hk-set-empty))))
(hk-set-size s))
1)
(hk-test
"hk-set-from-list: dedupes"
(hk-set-to-asc-list (hk-set-from-list (list 3 1 4 1 5 9 2 6)))
(list 1 2 3 4 5 6 9))
(hk-test
"hk-set-delete: removes"
(let
((s (hk-set-from-list (list 1 2 3))))
(hk-set-to-asc-list (hk-set-delete 2 s)))
(list 1 3))
(hk-test
"hk-set-union"
(hk-set-to-asc-list
(hk-set-union
(hk-set-from-list (list 1 2 3))
(hk-set-from-list (list 3 4 5))))
(list 1 2 3 4 5))
(hk-test
"hk-set-intersection"
(hk-set-to-asc-list
(hk-set-intersection
(hk-set-from-list (list 1 2 3 4))
(hk-set-from-list (list 3 4 5 6))))
(list 3 4))
(hk-test
"hk-set-difference"
(hk-set-to-asc-list
(hk-set-difference
(hk-set-from-list (list 1 2 3 4))
(hk-set-from-list (list 3 4 5))))
(list 1 2))
(hk-test
"hk-set-is-subset-of: yes"
(hk-set-is-subset-of
(hk-set-from-list (list 2 3))
(hk-set-from-list (list 1 2 3 4)))
true)
(hk-test
"hk-set-is-subset-of: no"
(hk-set-is-subset-of
(hk-set-from-list (list 5 6))
(hk-set-from-list (list 1 2 3 4)))
false)
(hk-test
"hk-set-filter"
(hk-set-to-asc-list
(hk-set-filter (fn (k) (> k 2)) (hk-set-from-list (list 1 2 3 4 5))))
(list 3 4 5))
(hk-test
"hk-set-map"
(hk-set-to-asc-list
(hk-set-map (fn (k) (* k 10)) (hk-set-from-list (list 1 2 3))))
(list 10 20 30))
(hk-test
"hk-set-foldr: sum"
(hk-set-foldr + 0 (hk-set-from-list (list 1 2 3 4 5)))
15)
;; ── Haskell-level (Set.* via import wiring) ──────────────────
(hk-test
"Set.size after Set.insert chain"
(hk-deep-force
(hk-run
"import qualified Data.Set as Set\nmain = Set.size (Set.insert 3 (Set.insert 1 (Set.insert 2 Set.empty)))"))
3)
(hk-test
"Set.member true"
(hk-deep-force
(hk-run
"import qualified Data.Set as Set\nmain = Set.member 5 (Set.insert 5 Set.empty)"))
(list "True"))
(hk-test
"Set.union via Haskell"
(hk-deep-force
(hk-run
"import Data.Set\nmain = Set.size (Set.union (Set.insert 1 Set.empty) (Set.insert 2 Set.empty))"))
2)
(hk-test
"Set.isSubsetOf via Haskell"
(hk-deep-force
(hk-run
"import qualified Data.Set as S\nmain = S.isSubsetOf (S.insert 1 S.empty) (S.insert 2 (S.insert 1 S.empty))"))
(list "True"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

140
lib/haskell/tests/show.sx Normal file
View File

@@ -0,0 +1,140 @@
;; show.sx — tests for the Show / Read class plumbing.
;;
;; Covers Phase 8:
;; - showsPrec / showParen / shows / showString stubs
;; - Read class stubs (reads / readsPrec / read)
;; - direct show coverage (Int, Bool, String, list, tuple, Maybe, ADT, ...)
;; ── ShowS / showsPrec / showParen stubs ──────────────────────
(hk-test
"shows: prepends show output"
(hk-deep-force (hk-run "main = shows 5 \"abc\""))
"5abc")
(hk-test
"shows: works on True"
(hk-deep-force (hk-run "main = shows True \"x\""))
"Truex")
(hk-test
"showString: prepends literal"
(hk-deep-force (hk-run "main = showString \"hello\" \" world\""))
"hello world")
(hk-test
"showParen True: wraps inner output in parens"
(hk-deep-force (hk-run "main = showParen True (showString \"inside\") \"\""))
"(inside)")
(hk-test
"showParen False: passes through unchanged"
(hk-deep-force (hk-run "main = showParen False (showString \"inside\") \"\""))
"inside")
(hk-test
"showsPrec: prepends show output regardless of prec"
(hk-deep-force (hk-run "main = showsPrec 11 42 \"end\""))
"42end")
(hk-test
"showParen + manual composition: build (Just 3)"
(hk-deep-force
(hk-run
"buildJust3 s = showString \"Just \" (shows 3 s)\nmain = showParen True buildJust3 \"\""))
"(Just 3)")
;; ── Read stubs ───────────────────────────────────────────────
(hk-test
"reads: stub returns empty list (null-check)"
(hk-deep-force (hk-run "main = show (null (reads \"42\"))"))
"True")
(hk-test
"readsPrec: stub returns empty list"
(hk-deep-force (hk-run "main = show (null (readsPrec 0 \"True\"))"))
"True")
(hk-test
"reads: type-checks in expression context (length)"
(hk-deep-force (hk-run "main = show (length (reads \"abc\"))"))
"0")
;; ── Direct `show` audit coverage ─────────────────────────────
(hk-test "show Int" (hk-deep-force (hk-run "main = show 42")) "42")
(hk-test
"show negative Int"
(hk-deep-force (hk-run "main = show (negate 5)"))
"-5")
(hk-test "show Bool True" (hk-deep-force (hk-run "main = show True")) "True")
(hk-test
"show Bool False"
(hk-deep-force (hk-run "main = show False"))
"False")
(hk-test
"show String quotes the value"
(hk-deep-force (hk-run "main = show \"hello\""))
"\"hello\"")
(hk-test
"show list of Int"
(hk-deep-force (hk-run "main = show [1,2,3]"))
"[1,2,3]")
(hk-test
"show empty list"
(hk-deep-force (hk-run "main = show (drop 5 [1,2,3])"))
"[]")
(hk-test
"show pair tuple"
(hk-deep-force (hk-run "main = show (1, True)"))
"(1,True)")
(hk-test
"show triple tuple"
(hk-deep-force (hk-run "main = show (1, 2, 3)"))
"(1,2,3)")
(hk-test
"show Maybe Nothing"
(hk-deep-force (hk-run "main = show Nothing"))
"Nothing")
(hk-test
"show Maybe Just"
(hk-deep-force (hk-run "main = show (Just 3)"))
"Just 3")
(hk-test
"show nested Just wraps inner in parens"
(hk-deep-force (hk-run "main = show (Just (Just 3))"))
"Just (Just 3)")
(hk-test
"show Just (negate 3) wraps negative in parens"
(hk-deep-force (hk-run "main = show (Just (negate 3))"))
"Just (-3)")
(hk-test
"show custom nullary ADT"
(hk-deep-force
(hk-run "data Day = Mon | Tue | Wed deriving (Show)\nmain = show Tue"))
"Tue")
(hk-test
"show custom multi-constructor ADT"
(hk-deep-force
(hk-run
"data Shape = Pt | Sq Int | Rect Int Int deriving (Show)\nmain = show (Rect 3 4)"))
"Rect 3 4")
(hk-test
"show list of Maybe wraps each element"
(hk-deep-force (hk-run "main = show [Just 1, Nothing, Just 2]"))
"[Just 1,Nothing,Just 2]")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

16
lib/haskell/tests/stdlib.sx
View File

@@ -37,11 +37,11 @@
(hk-ts "show neg" "negate 7" "-7")
(hk-ts "show bool T" "True" "True")
(hk-ts "show bool F" "False" "False")
(hk-ts "show list" "[1,2,3]" "[1, 2, 3]")
(hk-ts "show Just" "Just 5" "(Just 5)")
(hk-ts "show list" "[1,2,3]" "[1,2,3]")
(hk-ts "show Just" "Just 5" "Just 5")
(hk-ts "show Nothing" "Nothing" "Nothing")
(hk-ts "show LT" "LT" "LT")
(hk-ts "show tuple" "(1, True)" "(1, True)")
(hk-ts "show tuple" "(1, True)" "(1,True)")
;; ── Num extras ───────────────────────────────────────────────
(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
@@ -59,13 +59,13 @@
(hk-test
"foldr cons"
(hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
"[1, 2, 3]")
"[1,2,3]")
;; ── List ops ─────────────────────────────────────────────────
(hk-test
"reverse"
(hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
"[3, 2, 1]")
"[3,2,1]")
(hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True"))
(hk-test
"null xs"
@@ -82,7 +82,7 @@
(hk-test
"zip"
(hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
"[(1, 3), (2, 4)]")
"[(1,3),(2,4)]")
(hk-test "sum" (hk-deep-force (hk-run "main = sum [1,2,3,4,5]")) 15)
(hk-test "product" (hk-deep-force (hk-run "main = product [1,2,3,4]")) 24)
(hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
@@ -112,7 +112,7 @@
(hk-test
"fmap list"
(hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
"[2, 3, 4]")
"[2,3,4]")
;; ── Monad / Applicative ──────────────────────────────────────
(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
@@ -134,7 +134,7 @@
(hk-test
"lookup hit"
(hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
"(Just 20)")
"Just 20")
(hk-test
"lookup miss"
(hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))

139
lib/haskell/tests/string-char.sx Normal file
View File

@@ -0,0 +1,139 @@
;; String / Char tests — Phase 7 items 1-4.
;;
;; Covers:
;; hk-str? / hk-str-head / hk-str-tail / hk-str-null? (runtime helpers)
;; chr / ord / toUpper / toLower (builtins in eval)
;; cons-pattern on strings via match.sx (":"-intercept)
;; empty-list pattern on strings via match.sx ("[]"-intercept)
;; ── hk-str? predicate ────────────────────────────────────────────────────
(hk-test "hk-str? native string" (hk-str? "hello") true)
(hk-test "hk-str? empty string" (hk-str? "") true)
(hk-test "hk-str? view dict" (hk-str? {:hk-off 1 :hk-str "hi"}) true)
(hk-test "hk-str? rejects number" (hk-str? 42) false)
;; ── hk-str-null? predicate ───────────────────────────────────────────────
(hk-test "hk-str-null? empty string" (hk-str-null? "") true)
(hk-test "hk-str-null? non-empty" (hk-str-null? "a") false)
(hk-test "hk-str-null? exhausted view" (hk-str-null? {:hk-off 2 :hk-str "hi"}) true)
(hk-test "hk-str-null? live view" (hk-str-null? {:hk-off 1 :hk-str "hi"}) false)
;; ── hk-str-head ──────────────────────────────────────────────────────────
(hk-test "hk-str-head native string" (hk-str-head "hello") 104)
(hk-test "hk-str-head view at offset" (hk-str-head {:hk-off 1 :hk-str "hello"}) 101)
;; ── hk-str-tail ──────────────────────────────────────────────────────────
(hk-test "hk-str-tail of single char is nil" (hk-str-tail "h") (list "[]"))
(hk-test
"hk-str-tail of two-char string is live view"
(hk-str-null? (hk-str-tail "hi"))
false)
(hk-test
"hk-str-tail head of tail of hi is i"
(hk-str-head (hk-str-tail "hi"))
105)
;; ── chr / ord ────────────────────────────────────────────────────────────
(hk-test "chr 65 = A" (hk-eval-expr-source "chr 65") "A")
(hk-test "chr 104 = h" (hk-eval-expr-source "chr 104") "h")
(hk-test "ord char literal 'A' = 65" (hk-eval-expr-source "ord 'A'") 65)
(hk-test "ord char literal 'a' = 97" (hk-eval-expr-source "ord 'a'") 97)
(hk-test
"ord of head string = char code"
(hk-eval-expr-source "ord (head \"hello\")")
104)
;; ── toUpper / toLower ────────────────────────────────────────────────────
(hk-test "toUpper 97 = 65 (a->A)" (hk-eval-expr-source "toUpper 97") 65)
(hk-test
"toUpper 65 = 65 (already upper)"
(hk-eval-expr-source "toUpper 65")
65)
(hk-test
"toUpper 48 = 48 (digit unchanged)"
(hk-eval-expr-source "toUpper 48")
48)
(hk-test "toLower 65 = 97 (A->a)" (hk-eval-expr-source "toLower 65") 97)
(hk-test
"toLower 97 = 97 (already lower)"
(hk-eval-expr-source "toLower 97")
97)
(hk-test
"toLower 48 = 48 (digit unchanged)"
(hk-eval-expr-source "toLower 48")
48)
;; ── Pattern matching on strings ──────────────────────────────────────────
(hk-test
"cons pattern: head of hello = 104"
(hk-eval-expr-source "case \"hello\" of { (x:_) -> x }")
104)
(hk-test
"cons pattern: tail is traversable"
(hk-eval-expr-source "case \"hi\" of { (_:xs) -> case xs of { (y:_) -> y } }")
105)
(hk-test
"empty list pattern matches empty string"
(hk-eval-expr-source "case \"\" of { [] -> True; _ -> False }")
(list "True"))
(hk-test
"empty list pattern fails on non-empty"
(hk-eval-expr-source "case \"a\" of { [] -> True; _ -> False }")
(list "False"))
(hk-test
"cons pattern fails on empty string"
(hk-eval-expr-source "case \"\" of { (_:_) -> True; _ -> False }")
(list "False"))
;; ── Haskell programs using string traversal ──────────────────────────────
(hk-test
"null prelude on empty string"
(hk-eval-expr-source "null \"\"")
(list "True"))
(hk-test
"null prelude on non-empty string"
(hk-eval-expr-source "null \"abc\"")
(list "False"))
(hk-test
"length of string via cons recursion"
(hk-eval-expr-source "let { f [] = 0; f (_:xs) = 1 + f xs } in f \"hello\"")
5)
(hk-test
"map ord over string gives char codes"
(hk-deep-force (hk-eval-expr-source "map ord \"abc\""))
(list ":" 97 (list ":" 98 (list ":" 99 (list "[]")))))
(hk-test
"map toUpper over char codes then chr"
(hk-eval-expr-source "chr (toUpper (ord (head \"abc\")))")
"A")
(hk-test
"head then ord using prelude head"
(hk-eval-expr-source "ord (head \"hello\")")
104)

525
lib/tcl/runtime.sx
View File

@@ -73,59 +73,106 @@
(fn (full-stack level)
(nth full-stack level)))
; True if name starts with "::" (absolute namespace reference; for now we
; treat any "::name" as the global variable `name`). Multi-level namespace
; paths like "::ns::var" are not yet split — they're stored under the
; literal name in the global frame.
; Hot path on every var-get/set; only one char-at on the typical fast path.
(define
tcl-global-ref?
(fn (name)
(and
(equal? (char-at name 0) ":")
(equal? (char-at name 1) ":"))))
(define
tcl-strip-global
(fn (name)
(substring name 2 (string-length name))))
(define
tcl-var-get
(fn
(interp name)
(let
((val (frame-lookup (get interp :frame) name)))
(if
(nil? val)
(error (str "can't read \"" name "\": no such variable"))
(if
(tcl-global-ref? name)
; absolute reference — look up in global (root) frame
(let
((root-frame
(let ((stack (get interp :frame-stack)))
(if (= 0 (len stack)) (get interp :frame) (first stack))))
(gname (tcl-strip-global name)))
(let ((val (frame-lookup root-frame gname)))
(if
(nil? val)
(error (str "can't read \"" name "\": no such variable"))
val)))
(let
((val (frame-lookup (get interp :frame) name)))
(if
(upvar-alias? val)
; follow alias to target frame
(let
((target-level (get val :upvar-level))
(target-name (get val :upvar-name)))
(nil? val)
(error (str "can't read \"" name "\": no such variable"))
(if
(upvar-alias? val)
; follow alias to target frame
(let
((full-stack (tcl-full-stack interp)))
((target-level (get val :upvar-level))
(target-name (get val :upvar-name)))
(let
((target-frame (tcl-frame-nth full-stack target-level)))
((full-stack (tcl-full-stack interp)))
(let
((target-val (frame-lookup target-frame target-name)))
(if
(nil? target-val)
(error (str "can't read \"" name "\": no such variable"))
target-val)))))
val)))))
((target-frame (tcl-frame-nth full-stack target-level)))
(let
((target-val (frame-lookup target-frame target-name)))
(if
(nil? target-val)
(error (str "can't read \"" name "\": no such variable"))
target-val)))))
val))))))
(define
tcl-var-set
(fn
(interp name val)
(let
((cur-val (get (get (get interp :frame) :locals) name)))
(if
(and (not (nil? cur-val)) (upvar-alias? cur-val))
; set in target frame
(cond
((tcl-global-ref? name)
; absolute reference — set in global (root) frame
(let
((target-level (get cur-val :upvar-level))
(target-name (get cur-val :upvar-name)))
(let
((full-stack (tcl-full-stack interp)))
((stack (get interp :frame-stack)) (gname (tcl-strip-global name)))
(if
(= 0 (len stack))
; no frame stack — current frame is the root
(assoc interp :frame (frame-set-top (get interp :frame) gname val))
(let
((target-frame (tcl-frame-nth full-stack target-level)))
((root-frame (first stack))
(rest-stack (rest stack)))
(assoc
interp
:frame-stack
(cons (frame-set-top root-frame gname val) rest-stack))))))
(else
(let
((cur-val (get (get (get interp :frame) :locals) name)))
(if
(and (not (nil? cur-val)) (upvar-alias? cur-val))
; set in target frame
(let
((target-level (get cur-val :upvar-level))
(target-name (get cur-val :upvar-name)))
(let
((updated-target (frame-set-top target-frame target-name val)))
((full-stack (tcl-full-stack interp)))
(let
((new-full-stack (replace-at full-stack target-level updated-target)))
((target-frame (tcl-frame-nth full-stack target-level)))
(let
((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
(new-current (nth new-full-stack (- (len new-full-stack) 1))))
(assoc interp :frame new-current :frame-stack new-frame-stack)))))))
; normal set in current frame top
(assoc interp :frame (frame-set-top (get interp :frame) name val))))))
((updated-target (frame-set-top target-frame target-name val)))
(let
((new-full-stack (replace-at full-stack target-level updated-target)))
(let
((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
(new-current (nth new-full-stack (- (len new-full-stack) 1))))
(assoc interp :frame new-current :frame-stack new-frame-stack)))))))
; normal set in current frame top
(assoc interp :frame (frame-set-top (get interp :frame) name val))))))))
(define
tcl-eval-parts
@@ -292,15 +339,20 @@
(> (len result-stack) caller-stack-len)
(nth result-stack caller-stack-len)
(get interp :frame))))
; Forward result-interp as base so state changes inside
; the proc (e.g. :fileevents, :timers, :procs) propagate;
; restore caller's frame/stack/result/output/code.
(assoc result-interp
; Forward state that must escape the proc body —
; :commands, :procs, :fileevents, :timers. Without this
; fileevent registrations made inside a proc body are
; lost on return (broke socket -async accept handlers).
(assoc interp
:frame updated-caller
:frame-stack updated-below
:result result-val
:output (str caller-output proc-output)
:code (if (= code 2) 0 code))))))))))))))
:code (if (= code 2) 0 code)
:commands (get result-interp :commands)
:procs (get result-interp :procs)
:fileevents (get result-interp :fileevents)
:timers (get result-interp :timers))))))))))))))
(define
tcl-eval-cmd
@@ -1214,6 +1266,7 @@
(tcl-fmt-scan-num chars (+ j 1) (str acc-n ch))
{:num acc-n :j j})))))
; Walk format string char by char; dispatch each %spec to printf-spec.
(define
tcl-fmt-apply
(fn
@@ -1237,50 +1290,30 @@
(if
(>= i2 n-len)
(str acc "%")
(let
((c2 (nth chars i2)))
(if
(equal? c2 "%")
(tcl-fmt-apply
chars
n-len
fmt-args
(+ i2 1)
arg-idx
(str acc "%"))
(let
((fr (tcl-fmt-scan-flags chars i2 "")))
(if
(equal? (nth chars i2) "%")
; literal %%
(tcl-fmt-apply chars n-len fmt-args (+ i2 1) arg-idx (str acc "%"))
; dispatch via printf-spec
(let
((j (tcl-fmt-find-end chars i2 n-len)))
(if
(>= j n-len)
(str acc "?")
(let
((flags (get fr :flags)) (j (get fr :j)))
(let
((wr (tcl-fmt-scan-num chars j "")))
(let
((width (get wr :num)) (j2 (get wr :j)))
(let
((j3 (if (and (< j2 n-len) (equal? (nth chars j2) ".")) (let ((pr (tcl-fmt-scan-num chars (+ j2 1) ""))) (get pr :j)) j2)))
(if
(>= j3 n-len)
(str acc "?")
(let
((type-char (nth chars j3))
(cur-arg
(if
(< arg-idx (len fmt-args))
(nth fmt-args arg-idx)
"")))
(let
((zero-pad? (contains? (split flags "") "0"))
(left-align?
(contains? (split flags "") "-")))
(let
((formatted (cond ((or (equal? type-char "d") (equal? type-char "i")) (tcl-fmt-pad (str (parse-int cur-arg)) width zero-pad? left-align?)) ((equal? type-char "s") (tcl-fmt-pad cur-arg width false left-align?)) ((or (equal? type-char "f") (equal? type-char "g") (equal? type-char "e")) cur-arg) ((equal? type-char "x") (str (parse-int cur-arg))) ((equal? type-char "o") (str (parse-int cur-arg))) ((equal? type-char "c") cur-arg) (else (str "%" type-char)))))
(tcl-fmt-apply
chars
n-len
fmt-args
(+ j3 1)
(+ arg-idx 1)
(str acc formatted))))))))))))))))))))
((spec (str "%" (join "" (slice chars i2 (+ j 1)))))
(cur-arg
(if
(< arg-idx (len fmt-args))
(nth fmt-args arg-idx)
"")))
(tcl-fmt-apply
chars
n-len
fmt-args
(+ j 1)
(+ arg-idx 1)
(str acc (printf-spec spec cur-arg))))))))))))))
; --- string command helpers ---
@@ -1300,8 +1333,127 @@
interp
:result (tcl-fmt-apply chars n-len fmt-args 0 0 "")))))))
; toupper/tolower via char tables
(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))
; scan str fmt ?varName ...? — printf-style parse.
; Returns count of successful conversions. If varNames given, sets each to
; its conversion result; otherwise returns the values as a list.
(define
tcl-cmd-scan
(fn
(interp args)
(if
(< (len args) 2)
(error "scan: wrong # args")
(let
((input (first args))
(fmt (nth args 1))
(var-names (slice args 2 (len args))))
(let
((parsed
(tcl-scan-loop
input
(split fmt "")
(string-length fmt)
0
0
(list))))
(if
(= 0 (len var-names))
(assoc interp :result (tcl-list-build parsed))
(let
((bind-loop
(fn
(i-interp i)
(if
(>= i (len var-names))
i-interp
(let
((v (if (< i (len parsed)) (str (nth parsed i)) "")))
(bind-loop (tcl-var-set i-interp (nth var-names i) v) (+ i 1)))))))
(let ((bound (bind-loop interp 0)))
(assoc bound :result (str (len parsed)))))))))))
; Loop helper: walk format chars, dispatch each %spec to scan-spec.
(define
tcl-scan-loop
(fn
(input fmt-chars n-fmt fi pos values)
(if
(>= fi n-fmt)
values
(let
((c (nth fmt-chars fi)))
(cond
((equal? c "%")
(if
(>= (+ fi 1) n-fmt)
values
(let
((j (tcl-fmt-find-end fmt-chars (+ fi 1) n-fmt)))
(if
(>= j n-fmt)
values
(let
((spec (str "%" (join "" (slice fmt-chars (+ fi 1) (+ j 1)))))
(rem-str (substring input pos (string-length input))))
(let
((r (scan-spec spec rem-str)))
(if
(nil? r)
values
(tcl-scan-loop
input
fmt-chars
n-fmt
(+ j 1)
(+ pos (get r :consumed))
(append values (list (str (get r :value))))))))))))
((or (equal? c " ") (equal? c "\t") (equal? c "\n"))
(tcl-scan-loop
input
fmt-chars
n-fmt
(+ fi 1)
(tcl-skip-ws input pos)
values))
(else
(if
(and
(< pos (string-length input))
(equal? c (substring input pos (+ pos 1))))
(tcl-scan-loop input fmt-chars n-fmt (+ fi 1) (+ pos 1) values)
values)))))))
; Find end of a printf spec starting at fi (after '%'). Returns index of
; the conversion character.
(define
tcl-fmt-find-end
(fn
(chars i n)
(if
(>= i n)
i
(let
((c (nth chars i)))
(cond
((or (equal? c "-") (equal? c "+") (equal? c " ") (equal? c "0") (equal? c "#"))
(tcl-fmt-find-end chars (+ i 1) n))
((or (equal? c ".") (and (>= c "0") (<= c "9")))
(tcl-fmt-find-end chars (+ i 1) n))
(else i))))))
(define
tcl-skip-ws
(fn
(input pos)
(if
(>= pos (string-length input))
pos
(let
((c (substring input pos (+ pos 1))))
(if
(or (equal? c " ") (equal? c "\t") (equal? c "\n"))
(tcl-skip-ws input (+ pos 1))
pos)))))
(define
tcl-glob-match
@@ -2042,6 +2194,123 @@
((all-elems (reduce (fn (acc s) (append acc (tcl-list-split s))) (list) args)))
(assoc interp :result (tcl-list-build all-elems)))))
; lassign list var ?var ...? → assigns elements to vars; returns
; remaining unassigned elements as a list (empty string if all consumed)
(define
tcl-cmd-lassign
(fn
(interp args)
(if
(= 0 (len args))
(error "lassign: wrong # args")
(let
((elems (tcl-list-split (first args))) (vars (rest args)))
(let
((bind-loop
(fn
(i-interp i)
(if
(>= i (len vars))
i-interp
(let
((var (nth vars i))
(val (if (< i (len elems)) (nth elems i) "")))
(bind-loop (tcl-var-set i-interp var val) (+ i 1)))))))
(let
((bound (bind-loop interp 0)))
(let
((leftover
(if
(> (len elems) (len vars))
(slice elems (len vars) (len elems))
(list))))
(assoc bound :result (tcl-list-build leftover)))))))))
; lrepeat count ?elem ...? → list with elem... repeated count times
(define
tcl-cmd-lrepeat
(fn
(interp args)
(if
(= 0 (len args))
(error "lrepeat: wrong # args")
(let
((n (parse-int (first args))) (elems (rest args)))
(if
(or (< n 0) (= 0 (len elems)))
(assoc interp :result "")
(let
((build
(fn
(i acc)
(if (= i 0) acc (build (- i 1) (append acc elems))))))
(assoc interp :result (tcl-list-build (build n (list))))))))))
; lset varname index value → set element at index in list-valued variable
(define
tcl-cmd-lset
(fn
(interp args)
(if
(< (len args) 3)
(error "lset: wrong # args")
(let
((varname (first args))
(idx (parse-int (nth args 1)))
(val (nth args 2)))
(let
((cur (tcl-var-get interp varname)))
(let
((elems (tcl-list-split cur)))
(if
(or (< idx 0) (>= idx (len elems)))
(error (str "lset: index out of range " idx))
(let
((new-list (replace-at elems idx val)))
(let
((new-str (tcl-list-build new-list)))
(assoc
(tcl-var-set interp varname new-str)
:result new-str))))))))))
; lmap helper: like foreach-loop but collects body results
(define
tcl-lmap-loop
(fn
(interp varname items body acc)
(if
(= 0 (len items))
(assoc interp :result (tcl-list-build acc))
(let
((body-result (tcl-eval-string (tcl-var-set interp varname (first items)) body)))
(let
((code (get body-result :code)))
(cond
((= code 3) (assoc (assoc body-result :code 0) :result (tcl-list-build acc)))
((= code 4) (tcl-lmap-loop (assoc body-result :code 0) varname (rest items) body acc))
((= code 2) body-result)
((= code 1) body-result)
(else
(tcl-lmap-loop
(assoc body-result :code 0)
varname
(rest items)
body
(append acc (list (get body-result :result)))))))))))
(define
tcl-cmd-lmap
(fn
(interp args)
(if
(< (len args) 3)
(error "lmap: wrong # args")
(let
((varname (first args))
(list-str (nth args 1))
(body (nth args 2)))
(tcl-lmap-loop interp varname (tcl-list-split list-str) body (list))))))
; --- dict command helpers ---
; Parse flat dict string into SX list of [key val] pairs
@@ -2316,6 +2585,51 @@
(assoc
(tcl-var-set interp varname new-dict)
:result new-dict)))))))
((equal? sub "lappend")
; dict lappend dictVarName key elem ?elem ...?
(let
((varname (first rest-args))
(key (nth rest-args 1))
(new-elems (slice rest-args 2 (len rest-args))))
(let
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
(let
((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "" v))))
(let
((merged (tcl-list-build (append (tcl-list-split old-val) new-elems))))
(let
((new-dict (tcl-dict-set-pair cur key merged)))
(assoc
(tcl-var-set interp varname new-dict)
:result new-dict)))))))
((equal? sub "remove")
; dict remove dict ?key ...?
(let
((dict-str (first rest-args))
(keys-to-remove (rest rest-args)))
(assoc
interp
:result (reduce
(fn (acc k) (tcl-dict-unset-key acc k))
dict-str
keys-to-remove))))
((equal? sub "filter")
; dict filter dict key pattern — only `key` filter supported
(let
((dict-str (first rest-args))
(mode (nth rest-args 1))
(pattern (nth rest-args 2)))
(if
(not (equal? mode "key"))
(error (str "dict filter: only key filter implemented, got " mode))
(let
((kept
(filter
(fn (pair) (tcl-glob-match (split pattern "") (split (first pair) "")))
(tcl-dict-to-pairs dict-str))))
(assoc
interp
:result (tcl-dict-from-pairs kept))))))
(else (error (str "dict: unknown subcommand \"" sub "\""))))))))
; Qualify a proc name relative to current-ns.
@@ -2782,7 +3096,7 @@
(let
((varname (first rest-args)))
(let
((val (frame-lookup (get interp :frame) varname)))
((val (tcl-var-lookup-or-nil interp varname)))
(assoc interp :result (if (nil? val) "0" "1")))))
((equal? sub "hostname") (assoc interp :result "localhost"))
((equal? sub "script") (assoc interp :result ""))
@@ -3011,6 +3325,13 @@
(fn
(interp args)
(let ((_ (channel-flush (first args)))) (assoc interp :result ""))))
; exec cmd ?arg ...? — run external process, return stdout (newline-stripped)
(define
tcl-cmd-exec
(fn
(interp args)
(assoc interp :result (exec-process args))))
(define
tcl-cmd-fconfigure
(fn
@@ -3223,6 +3544,22 @@
(tcl-event-step interp (- target-ms now))
target-ms)))))
; Look up a Tcl var by name, returning nil instead of erroring if missing.
; Handles `::var` global-prefix routing the same way tcl-var-get does.
(define
tcl-var-lookup-or-nil
(fn
(interp name)
(if
(tcl-global-ref? name)
(let
((root-frame
(let ((stack (get interp :frame-stack)))
(if (= 0 (len stack)) (get interp :frame) (first stack))))
(gname (tcl-strip-global name)))
(frame-lookup root-frame gname))
(frame-lookup (get interp :frame) name))))
(define
tcl-cmd-vwait
(fn
@@ -3233,7 +3570,7 @@
(let
((name (first args)))
(let
((initial (frame-lookup (get interp :frame) name)))
((initial (tcl-var-lookup-or-nil interp name)))
(assoc (tcl-vwait-loop interp name initial) :result ""))))))
(define
@@ -3241,7 +3578,7 @@
(fn
(interp name initial)
(let
((cur (frame-lookup (get interp :frame) name)))
((cur (tcl-var-lookup-or-nil interp name)))
(if
(and (not (nil? cur)) (not (equal? cur initial)))
interp
@@ -3783,6 +4120,16 @@
((i (tcl-register i "linsert" tcl-cmd-linsert)))
(let
((i (tcl-register i "concat" tcl-cmd-concat)))
(let
((i (tcl-register i "lassign" tcl-cmd-lassign)))
(let
((i (tcl-register i "lrepeat" tcl-cmd-lrepeat)))
(let
((i (tcl-register i "lset" tcl-cmd-lset)))
(let
((i (tcl-register i "lmap" tcl-cmd-lmap)))
(let
((i (tcl-register i "exec" tcl-cmd-exec)))
(let
((i (tcl-register i "split" tcl-cmd-split)))
(let
@@ -3856,4 +4203,4 @@
(tcl-register
i
"array"
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

109
lib/tcl/tests/idioms.sx
View File

@@ -415,6 +415,115 @@
:result)
"")
; 60-63. Phase 6a namespace :: prefix
(ok "ns-set-from-proc-reaches-global"
(get
(run
"proc f {x} { set ::g $x }\nf hello\nset ::g")
:result)
"hello")
(ok "ns-read-from-proc"
(get
(run
"set ::v 42\nproc f {} { return $::v }\nf")
:result)
"42")
(ok "ns-incr-via-prefix"
(get
(run
"set ::n 5\nproc bump {} { incr ::n }\nbump\nbump\nset ::n")
:result)
"7")
(ok "ns-different-from-local"
(get
(run
"set x outer\nproc f {} { set x inner; set ::x global; return $x }\nf")
:result)
"inner")
; 64-69. Phase 6b list ops (lassign, lrepeat, lset, lmap)
(ok "lassign-three"
(get (run "lassign {a b c d e} x y z\nlist $x $y $z") :result)
"a b c")
(ok "lassign-leftover"
(get (run "lassign {1 2 3 4 5} a b") :result)
"3 4 5")
(ok "lrepeat-basic"
(get (run "lrepeat 3 a") :result)
"a a a")
(ok "lrepeat-multi"
(get (run "lrepeat 2 x y") :result)
"x y x y")
(ok "lset-replaces"
(get (run "set L {a b c d}\nlset L 2 ZZ\nset L") :result)
"a b ZZ d")
(ok "lmap-square"
(get (run "lmap n {1 2 3 4} {expr {$n * $n}}") :result)
"1 4 9 16")
; 70-72. Phase 6c dict additions (lappend, remove, filter)
(ok "dict-lappend-extends"
(get (run "set d {tags {a b}}\ndict lappend d tags c d\nset d") :result)
"tags {a b c d}")
(ok "dict-remove"
(get (run "dict remove {a 1 b 2 c 3} b") :result)
"a 1 c 3")
(ok "dict-filter-key"
(get (run "dict filter {alpha 1 beta 2 gamma 3} key a*") :result)
"alpha 1")
; 73-79. Phase 6d format and scan
(ok "format-int-padded"
(get (run "format {%05d} 42") :result)
"00042")
(ok "format-float-precision"
(get (run "format {%.2f} 3.14159") :result)
"3.14")
(ok "format-hex"
(get (run "format {%x} 255") :result)
"ff")
(ok "format-char"
(get (run "format {%c} 65") :result)
"A")
(ok "format-string-left"
(get (run "format {%-5s|} hi") :result)
"hi |")
(ok "scan-two-ints"
(get (run "scan {12 34} {%d %d} a b\nlist $a $b") :result)
"12 34")
(ok "scan-count"
(get (run "scan {hello 42} {%s %d}") :result)
"hello 42")
; 80-82. Phase 6e exec
(ok "exec-echo"
(get (run "exec echo hello world") :result)
"hello world")
(ok "exec-printf-no-newline"
(get (run "exec /bin/printf x") :result)
"x")
(ok "exec-with-args"
(get (run "exec /bin/echo -n test") :result)
"test")
(dict
"passed"
tcl-idiom-pass

4
lib/tcl/tokenizer.sx
View File

@@ -158,7 +158,9 @@
(begin
(when (= (cur) "}") (advance! 1))
{:type "var" :name name}))))))
((tcl-ident-start? (cur))
((or
(tcl-ident-start? (cur))
(and (= (cur) ":") (= (char-at 1) ":")))
(let ((start pos))
(begin
(scan-ns-name!)