haskell: classic program fib.hs + source-order top-level binding (+2 tests, 388/388)

lib/haskell/desugar.sx

@@ -0,0 +1,249 @@
+;; Desugar the Haskell surface AST into a smaller core AST.
+;;
+;; Eliminates the three surface-only shapes produced by the parser:
+;;   :where BODY DECLS     →  :let DECLS BODY
+;;   :guarded GUARDS       →  :if C1 E1 (:if C2 E2 … (:app error …))
+;;   :list-comp EXPR QUALS →  concatMap-based expression (§3.11)
+;;
+;; Everything else (:app, :op, :lambda, :let, :case, :do, :tuple,
+;; :list, :range, :if, :neg, :sect-left / :sect-right, plus all
+;; leaf forms and pattern / type nodes) is passed through after
+;; recursing into children.
+
+(define
+  hk-guards-to-if
+  (fn
+    (guards)
+    (cond
+      ((empty? guards)
+        (list
+          :app
+          (list :var "error")
+          (list :string "Non-exhaustive guards")))
+      (:else
+        (let
+          ((g (first guards)))
+          (list
+            :if
+            (hk-desugar (nth g 1))
+            (hk-desugar (nth g 2))
+            (hk-guards-to-if (rest guards))))))))
+
+;; do-notation desugaring (Haskell 98 §3.14):
+;;   do { e }              =  e
+;;   do { e ; ss }         =  e >> do { ss }
+;;   do { p <- e ; ss }    =  e >>= \p -> do { ss }
+;;   do { let decls ; ss } =  let decls in do { ss }
+(define
+  hk-desugar-do
+  (fn
+    (stmts)
+    (cond
+      ((empty? stmts) (raise "empty do block"))
+      ((empty? (rest stmts))
+        (let ((s (first stmts)))
+          (cond
+            ((= (first s) "do-expr") (hk-desugar (nth s 1)))
+            (:else
+              (raise "do block must end with an expression")))))
+      (:else
+        (let
+          ((s (first stmts)) (rest-stmts (rest stmts)))
+          (let
+            ((rest-do (hk-desugar-do rest-stmts)))
+            (cond
+              ((= (first s) "do-expr")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var ">>")
+                    (hk-desugar (nth s 1)))
+                  rest-do))
+              ((= (first s) "do-bind")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var ">>=")
+                    (hk-desugar (nth s 2)))
+                  (list :lambda (list (nth s 1)) rest-do)))
+              ((= (first s) "do-let")
+                (list
+                  :let
+                  (map hk-desugar (nth s 1))
+                  rest-do))
+              (:else (raise "unknown do-stmt tag")))))))))
+
+;; List-comprehension desugaring (Haskell 98 §3.11):
+;;   [e |             ]  =  [e]
+;;   [e | b,     Q    ]  =  if b then [e | Q] else []
+;;   [e | p <- l, Q    ]  =  concatMap (\p -> [e | Q]) l
+;;   [e | let ds, Q    ]  =  let ds in [e | Q]
+(define
+  hk-lc-desugar
+  (fn
+    (e quals)
+    (cond
+      ((empty? quals) (list :list (list e)))
+      (:else
+        (let
+          ((q (first quals)))
+          (let
+            ((qtag (first q)))
+            (cond
+              ((= qtag "q-guard")
+                (list
+                  :if
+                  (hk-desugar (nth q 1))
+                  (hk-lc-desugar e (rest quals))
+                  (list :list (list))))
+              ((= qtag "q-gen")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var "concatMap")
+                    (list
+                      :lambda
+                      (list (nth q 1))
+                      (hk-lc-desugar e (rest quals))))
+                  (hk-desugar (nth q 2))))
+              ((= qtag "q-let")
+                (list
+                  :let
+                  (map hk-desugar (nth q 1))
+                  (hk-lc-desugar e (rest quals))))
+              (:else
+                (raise
+                  (str
+                    "hk-lc-desugar: unknown qualifier tag "
+                    qtag))))))))))
+
+(define
+  hk-desugar
+  (fn
+    (node)
+    (cond
+      ((not (list? node)) node)
+      ((empty? node) node)
+      (:else
+        (let
+          ((tag (first node)))
+          (cond
+            ;; Transformations
+            ((= tag "where")
+              (list
+                :let
+                (map hk-desugar (nth node 2))
+                (hk-desugar (nth node 1))))
+            ((= tag "guarded") (hk-guards-to-if (nth node 1)))
+            ((= tag "list-comp")
+              (hk-lc-desugar
+                (hk-desugar (nth node 1))
+                (nth node 2)))
+
+            ;; Expression nodes
+            ((= tag "app")
+              (list
+                :app
+                (hk-desugar (nth node 1))
+                (hk-desugar (nth node 2))))
+            ((= tag "op")
+              (list
+                :op
+                (nth node 1)
+                (hk-desugar (nth node 2))
+                (hk-desugar (nth node 3))))
+            ((= tag "neg") (list :neg (hk-desugar (nth node 1))))
+            ((= tag "if")
+              (list
+                :if
+                (hk-desugar (nth node 1))
+                (hk-desugar (nth node 2))
+                (hk-desugar (nth node 3))))
+            ((= tag "tuple")
+              (list :tuple (map hk-desugar (nth node 1))))
+            ((= tag "list")
+              (list :list (map hk-desugar (nth node 1))))
+            ((= tag "range")
+              (list
+                :range
+                (hk-desugar (nth node 1))
+                (hk-desugar (nth node 2))))
+            ((= tag "range-step")
+              (list
+                :range-step
+                (hk-desugar (nth node 1))
+                (hk-desugar (nth node 2))
+                (hk-desugar (nth node 3))))
+            ((= tag "lambda")
+              (list
+                :lambda
+                (nth node 1)
+                (hk-desugar (nth node 2))))
+            ((= tag "let")
+              (list
+                :let
+                (map hk-desugar (nth node 1))
+                (hk-desugar (nth node 2))))
+            ((= tag "case")
+              (list
+                :case
+                (hk-desugar (nth node 1))
+                (map hk-desugar (nth node 2))))
+            ((= tag "alt")
+              (list :alt (nth node 1) (hk-desugar (nth node 2))))
+            ((= tag "do") (hk-desugar-do (nth node 1)))
+            ((= tag "sect-left")
+              (list
+                :sect-left
+                (nth node 1)
+                (hk-desugar (nth node 2))))
+            ((= tag "sect-right")
+              (list
+                :sect-right
+                (nth node 1)
+                (hk-desugar (nth node 2))))
+
+            ;; Top-level
+            ((= tag "program")
+              (list :program (map hk-desugar (nth node 1))))
+            ((= tag "module")
+              (list
+                :module
+                (nth node 1)
+                (nth node 2)
+                (nth node 3)
+                (map hk-desugar (nth node 4))))
+
+            ;; Decls carrying a body
+            ((= tag "fun-clause")
+              (list
+                :fun-clause
+                (nth node 1)
+                (nth node 2)
+                (hk-desugar (nth node 3))))
+            ((= tag "pat-bind")
+              (list
+                :pat-bind
+                (nth node 1)
+                (hk-desugar (nth node 2))))
+            ((= tag "bind")
+              (list
+                :bind
+                (nth node 1)
+                (hk-desugar (nth node 2))))
+
+            ;; Everything else: leaf literals, vars, cons, patterns,
+            ;; types, imports, type-sigs, data / newtype / fixity, …
+            (:else node)))))))
+
+;; Convenience — tokenize + layout + parse + desugar.
+(define
+  hk-core
+  (fn (src) (hk-desugar (hk-parse-top src))))
+
+(define
+  hk-core-expr
+  (fn (src) (hk-desugar (hk-parse src))))

lib/haskell/eval.sx

@@ -0,0 +1,785 @@
+;; Haskell strict evaluator (Phase 2).
+;;
+;; Consumes the post-desugar core AST and produces SX values. Strict
+;; throughout — laziness and thunks are Phase 3.
+;;
+;; Value representation:
+;;   numbers / strings / chars      → raw SX values
+;;   constructor values             → tagged lists (con-name first)
+;;   functions: closure / multifun  → {:type "fn" :kind … …}
+;;   constructor partials           → {:type "con-partial" …}
+;;   built-ins                      → {:type "builtin" …}
+;;
+;; Multi-clause top-level definitions are bundled into a single
+;; multifun keyed by name; arguments are gathered through currying
+;; until arity is reached, then each clause's pattern list is matched
+;; in order. Recursive let bindings work because the binding env is
+;; built mutably so closures captured during evaluation see the
+;; eventual full env.
+
+(define
+  hk-dict-copy
+  (fn
+    (d)
+    (let ((nd (dict)))
+      (for-each
+        (fn (k) (dict-set! nd k (get d k)))
+        (keys d))
+      nd)))
+
+;; ── Thunks (Phase 3 — laziness) ─────────────────────────────
+;; A thunk wraps an unevaluated AST plus the env in which it was
+;; created. The first call to `hk-force` evaluates the body, replaces
+;; the body with the cached value, and flips `forced`. Subsequent
+;; forces return the cached value directly.
+(define
+  hk-mk-thunk
+  (fn
+    (body env)
+    {:type "thunk" :body body :env env :forced false :value nil}))
+
+(define
+  hk-is-thunk?
+  (fn (v) (and (dict? v) (= (get v "type") "thunk"))))
+
+(define
+  hk-force
+  (fn
+    (v)
+    (cond
+      ((hk-is-thunk? v)
+        (cond
+          ((get v "forced") (get v "value"))
+          (:else
+            (let
+              ((res (hk-force (hk-eval (get v "body") (get v "env")))))
+              (dict-set! v "forced" true)
+              (dict-set! v "value" res)
+              res))))
+      (:else v))))
+
+;; Recursive force — used at the test/output boundary so test
+;; expectations can compare against fully-evaluated structures.
+(define
+  hk-deep-force
+  (fn
+    (v)
+    (let ((fv (hk-force v)))
+      (cond
+        ((not (list? fv)) fv)
+        ((empty? fv) fv)
+        (:else (map hk-deep-force fv))))))
+
+;; ── Function value constructors ──────────────────────────────
+(define
+  hk-mk-closure
+  (fn
+    (params body env)
+    {:type "fn" :kind "closure" :params params :body body :env env}))
+
+(define
+  hk-mk-multifun
+  (fn
+    (arity clauses env)
+    {:type "fn" :kind "multi" :arity arity :clauses clauses :env env :collected (list)}))
+
+(define
+  hk-mk-builtin
+  (fn
+    (name fn arity)
+    {:type "builtin" :name name :fn fn :arity arity :lazy false :collected (list)}))
+
+;; A lazy built-in receives its collected args as raw thunks (or
+;; values, if those happened to be eager) — the implementation is
+;; responsible for forcing exactly what it needs. Used for `seq`
+;; and `deepseq`, which are non-strict in their second argument.
+(define
+  hk-mk-lazy-builtin
+  (fn
+    (name fn arity)
+    {:type "builtin" :name name :fn fn :arity arity :lazy true :collected (list)}))
+
+;; ── Apply a function value to one argument ──────────────────
+(define
+  hk-apply
+  (fn
+    (f arg)
+    (let ((f (hk-force f)))
+      (cond
+        ((not (dict? f))
+          (raise (str "apply: not a function value: " f)))
+        ((= (get f "type") "fn")
+          (cond
+            ((= (get f "kind") "closure") (hk-apply-closure f arg))
+            ((= (get f "kind") "multi") (hk-apply-multi f arg))
+            (:else (raise "apply: unknown fn kind"))))
+        ((= (get f "type") "con-partial") (hk-apply-con-partial f arg))
+        ((= (get f "type") "builtin") (hk-apply-builtin f arg))
+        (:else (raise "apply: not a function dict"))))))
+
+(define
+  hk-apply-closure
+  (fn
+    (cl arg)
+    (let
+      ((params (get cl "params"))
+        (body (get cl "body"))
+        (env (get cl "env")))
+      (cond
+        ((empty? params) (raise "apply-closure: no params"))
+        (:else
+          (let
+            ((p1 (first params)) (rest-p (rest params)))
+            (let
+              ((env-after (hk-match p1 arg env)))
+              (cond
+                ((nil? env-after)
+                  (raise "pattern match failure in lambda"))
+                ((empty? rest-p) (hk-eval body env-after))
+                (:else
+                  (hk-mk-closure rest-p body env-after))))))))))
+
+(define
+  hk-apply-multi
+  (fn
+    (mf arg)
+    (let
+      ((arity (get mf "arity"))
+        (clauses (get mf "clauses"))
+        (env (get mf "env"))
+        (collected (append (get mf "collected") (list arg))))
+      (cond
+        ((< (len collected) arity)
+          (assoc mf "collected" collected))
+        (:else (hk-dispatch-multi clauses collected env))))))
+
+(define
+  hk-dispatch-multi
+  (fn
+    (clauses args env)
+    (cond
+      ((empty? clauses)
+        (raise "non-exhaustive patterns in function definition"))
+      (:else
+        (let
+          ((c (first clauses)))
+          (let
+            ((pats (first c)) (body (first (rest c))))
+            (let
+              ((env-after (hk-match-args pats args env)))
+              (cond
+                ((nil? env-after)
+                  (hk-dispatch-multi (rest clauses) args env))
+                (:else (hk-eval body env-after))))))))))
+
+(define
+  hk-match-args
+  (fn
+    (pats args env)
+    (cond
+      ((empty? pats) env)
+      (:else
+        (let
+          ((res (hk-match (first pats) (first args) env)))
+          (cond
+            ((nil? res) nil)
+            (:else
+              (hk-match-args (rest pats) (rest args) res))))))))
+
+(define
+  hk-apply-con-partial
+  (fn
+    (cp arg)
+    (let
+      ((name (get cp "name"))
+        (arity (get cp "arity"))
+        (args (append (get cp "args") (list arg))))
+      (cond
+        ((= (len args) arity) (hk-mk-con name args))
+        (:else (assoc cp "args" args))))))
+
+(define
+  hk-apply-builtin
+  (fn
+    (b arg)
+    (let
+      ((arity (get b "arity"))
+        (collected (append (get b "collected") (list arg))))
+      (cond
+        ((< (len collected) arity)
+          (assoc b "collected" collected))
+        (:else
+          ;; Strict built-ins force every collected arg before
+          ;; calling. Lazy ones (`seq`, `deepseq`) receive the raw
+          ;; thunks so they can choose what to force.
+          (cond
+            ((get b "lazy") (apply (get b "fn") collected))
+            (:else
+              (apply
+                (get b "fn")
+                (map hk-force collected)))))))))
+
+;; ── Bool helpers (Bool values are tagged conses) ────────────
+(define
+  hk-truthy?
+  (fn
+    (v)
+    (and (list? v) (not (empty? v)) (= (first v) "True"))))
+
+(define hk-true (hk-mk-con "True" (list)))
+(define hk-false (hk-mk-con "False" (list)))
+(define hk-of-bool (fn (b) (if b hk-true hk-false)))
+
+;; ── Core eval ───────────────────────────────────────────────
+(define
+  hk-eval
+  (fn
+    (node env)
+    (cond
+      ((not (list? node)) (raise (str "eval: not a list: " node)))
+      ((empty? node) (raise "eval: empty list node"))
+      (:else
+        (let
+          ((tag (first node)))
+          (cond
+            ((= tag "int") (nth node 1))
+            ((= tag "float") (nth node 1))
+            ((= tag "string") (nth node 1))
+            ((= tag "char") (nth node 1))
+            ((= tag "var") (hk-eval-var (nth node 1) env))
+            ((= tag "con") (hk-eval-con-ref (nth node 1)))
+            ((= tag "neg")
+              (- 0 (hk-force (hk-eval (nth node 1) env))))
+            ((= tag "if") (hk-eval-if node env))
+            ((= tag "let") (hk-eval-let (nth node 1) (nth node 2) env))
+            ((= tag "lambda")
+              (hk-mk-closure (nth node 1) (nth node 2) env))
+            ((= tag "app")
+              (hk-apply
+                (hk-eval (nth node 1) env)
+                (hk-mk-thunk (nth node 2) env)))
+            ((= tag "op")
+              (hk-eval-op
+                (nth node 1)
+                (nth node 2)
+                (nth node 3)
+                env))
+            ((= tag "case")
+              (hk-eval-case (nth node 1) (nth node 2) env))
+            ((= tag "tuple")
+              (hk-mk-tuple
+                (map (fn (e) (hk-eval e env)) (nth node 1))))
+            ((= tag "list")
+              (hk-mk-list
+                (map (fn (e) (hk-eval e env)) (nth node 1))))
+            ((= tag "range")
+              (let
+                ((from (hk-force (hk-eval (nth node 1) env)))
+                  (to (hk-force (hk-eval (nth node 2) env))))
+                (hk-build-range from to 1)))
+            ((= tag "range-step")
+              (let
+                ((from (hk-force (hk-eval (nth node 1) env)))
+                  (nxt (hk-force (hk-eval (nth node 2) env)))
+                  (to (hk-force (hk-eval (nth node 3) env))))
+                (hk-build-range from to (- nxt from))))
+            ((= tag "range-from")
+              ;; [from..] = iterate (+ 1) from — uses the Prelude.
+              (hk-eval
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var "iterate")
+                    (list
+                      :sect-right
+                      "+"
+                      (list :int 1)))
+                  (nth node 1))
+                env))
+            ((= tag "sect-left")
+              (hk-eval-sect-left (nth node 1) (nth node 2) env))
+            ((= tag "sect-right")
+              (hk-eval-sect-right (nth node 1) (nth node 2) env))
+            (:else
+              (raise (str "eval: unknown node tag '" tag "'")))))))))
+
+(define
+  hk-eval-var
+  (fn
+    (name env)
+    (cond
+      ((has-key? env name) (get env name))
+      ((hk-is-con? name) (hk-eval-con-ref name))
+      (:else (raise (str "unbound variable: " name))))))
+
+(define
+  hk-eval-con-ref
+  (fn
+    (name)
+    (let ((arity (hk-con-arity name)))
+      (cond
+        ((nil? arity) (raise (str "unknown constructor: " name)))
+        ((= arity 0) (hk-mk-con name (list)))
+        (:else
+          {:type "con-partial" :name name :arity arity :args (list)})))))
+
+(define
+  hk-eval-if
+  (fn
+    (node env)
+    (let ((cv (hk-force (hk-eval (nth node 1) env))))
+      (cond
+        ((hk-truthy? cv) (hk-eval (nth node 2) env))
+        ((and (list? cv) (= (first cv) "False"))
+          (hk-eval (nth node 3) env))
+        ((= cv true) (hk-eval (nth node 2) env))
+        ((= cv false) (hk-eval (nth node 3) env))
+        (:else (raise "if: condition is not Bool"))))))
+
+(define
+  hk-extend-env-with-match!
+  (fn
+    (env match-env)
+    (for-each
+      (fn (k) (dict-set! env k (get match-env k)))
+      (keys match-env))))
+
+(define
+  hk-eval-let-bind!
+  (fn
+    (b env)
+    (let ((tag (first b)))
+      (cond
+        ((= tag "fun-clause")
+          (let
+            ((name (nth b 1))
+              (pats (nth b 2))
+              (body (nth b 3)))
+            (cond
+              ((empty? pats)
+                (dict-set! env name (hk-eval body env)))
+              (:else
+                (dict-set! env name (hk-mk-closure pats body env))))))
+        ((or (= tag "bind") (= tag "pat-bind"))
+          (let ((pat (nth b 1)) (body (nth b 2)))
+            (let ((val (hk-eval body env)))
+              (let ((res (hk-match pat val env)))
+                (cond
+                  ((nil? res)
+                    (raise "let: pattern bind failure"))
+                  (:else
+                    (hk-extend-env-with-match! env res)))))))
+        (:else nil)))))
+
+(define
+  hk-eval-let
+  (fn
+    (binds body env)
+    (let ((new-env (hk-dict-copy env)))
+      ;; Pre-seed names for fn-clauses so closures see themselves
+      ;; (mutual recursion across the whole binding group).
+      (for-each
+        (fn (b)
+          (cond
+            ((= (first b) "fun-clause")
+              (dict-set! new-env (nth b 1) nil))
+            ((and
+                (= (first b) "bind")
+                (list? (nth b 1))
+                (= (first (nth b 1)) "p-var"))
+              (dict-set! new-env (nth (nth b 1) 1) nil))
+            (:else nil)))
+        binds)
+      (for-each (fn (b) (hk-eval-let-bind! b new-env)) binds)
+      (hk-eval body new-env))))
+
+(define
+  hk-eval-case
+  (fn
+    (scrut alts env)
+    (let ((sv (hk-force (hk-eval scrut env))))
+      (hk-try-alts alts sv env))))
+
+(define
+  hk-try-alts
+  (fn
+    (alts val env)
+    (cond
+      ((empty? alts) (raise "case: non-exhaustive patterns"))
+      (:else
+        (let
+          ((alt (first alts)))
+          (let
+            ((pat (nth alt 1)) (body (nth alt 2)))
+            (let
+              ((res (hk-match pat val env)))
+              (cond
+                ((nil? res) (hk-try-alts (rest alts) val env))
+                (:else (hk-eval body res))))))))))
+
+(define
+  hk-eval-op
+  (fn
+    (op left right env)
+    (cond
+      ;; Cons is non-strict in both args: build a cons cell whose
+      ;; head and tail are deferred. This is what makes `repeat x =
+      ;; x : repeat x` and `fibs = 0 : 1 : zipWith (+) fibs (tail
+      ;; fibs)` terminate.
+      ((= op ":")
+        (hk-mk-cons
+          (hk-mk-thunk left env)
+          (hk-mk-thunk right env)))
+      (:else
+        (let
+          ((lv (hk-force (hk-eval left env)))
+            (rv (hk-force (hk-eval right env))))
+          (hk-binop op lv rv))))))
+
+(define
+  hk-list-append
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (= (first a) "[]")) b)
+      ((and (list? a) (= (first a) ":"))
+        (hk-mk-cons (nth a 1) (hk-list-append (nth a 2) b)))
+      (:else (raise "++: not a list")))))
+
+;; Eager finite-range spine — handles [from..to] and [from,next..to].
+;; Step direction is governed by the sign of `step`; when step > 0 we
+;; stop at to; when step < 0 we stop at to going down.
+(define
+  hk-build-range
+  (fn
+    (from to step)
+    (cond
+      ((and (> step 0) (> from to)) (hk-mk-nil))
+      ((and (< step 0) (< from to)) (hk-mk-nil))
+      ((= step 0) (hk-mk-nil))
+      (:else
+        (hk-mk-cons from (hk-build-range (+ from step) to step))))))
+
+(define
+  hk-binop
+  (fn
+    (op lv rv)
+    (cond
+      ((= op "+") (+ lv rv))
+      ((= op "-") (- lv rv))
+      ((= op "*") (* lv rv))
+      ((= op "/") (/ lv rv))
+      ((= op "==") (hk-of-bool (= lv rv)))
+      ((= op "/=") (hk-of-bool (not (= lv rv))))
+      ((= op "<") (hk-of-bool (< lv rv)))
+      ((= op "<=") (hk-of-bool (<= lv rv)))
+      ((= op ">") (hk-of-bool (> lv rv)))
+      ((= op ">=") (hk-of-bool (>= lv rv)))
+      ((= op "&&") (hk-of-bool (and (hk-truthy? lv) (hk-truthy? rv))))
+      ((= op "||") (hk-of-bool (or (hk-truthy? lv) (hk-truthy? rv))))
+      ((= op ":") (hk-mk-cons lv rv))
+      ((= op "++") (hk-list-append lv rv))
+      (:else (raise (str "unknown operator: " op))))))
+
+(define
+  hk-eval-sect-left
+  (fn
+    (op e env)
+    ;; (e op) = \x -> e op x — bind e once, defer the operator call.
+    (let ((ev (hk-eval e env)))
+      (let ((cenv (hk-dict-copy env)))
+        (dict-set! cenv "__hk-sect-l" ev)
+        (hk-mk-closure
+          (list (list :p-var "__hk-sect-x"))
+          (list
+            :op
+            op
+            (list :var "__hk-sect-l")
+            (list :var "__hk-sect-x"))
+          cenv)))))
+
+(define
+  hk-eval-sect-right
+  (fn
+    (op e env)
+    (let ((ev (hk-eval e env)))
+      (let ((cenv (hk-dict-copy env)))
+        (dict-set! cenv "__hk-sect-r" ev)
+        (hk-mk-closure
+          (list (list :p-var "__hk-sect-x"))
+          (list
+            :op
+            op
+            (list :var "__hk-sect-x")
+            (list :var "__hk-sect-r"))
+          cenv)))))
+
+;; ── Top-level program evaluation ────────────────────────────
+;; Operator-as-value built-ins — let `(+)`, `(*)`, etc. work as
+;; first-class functions for `zipWith (+)` and friends. Strict in
+;; both args (built-ins are forced via hk-apply-builtin).
+(define
+  hk-make-binop-builtin
+  (fn
+    (name op-name)
+    (hk-mk-builtin
+      name
+      (fn (a b) (hk-binop op-name a b))
+      2)))
+
+;; Inline Prelude source — loaded into the initial env so simple
+;; programs can use `head`, `take`, `repeat`, etc. without each
+;; user file redefining them. The Prelude itself uses lazy `:` for
+;; the recursive list-building functions.
+(define
+  hk-prelude-src
+  "head (x:_) = x
+tail (_:xs) = xs
+fst (a, _) = a
+snd (_, b) = b
+take 0 _ = []
+take _ [] = []
+take n (x:xs) = x : take (n - 1) xs
+drop 0 xs = xs
+drop _ [] = []
+drop n (_:xs) = drop (n - 1) xs
+repeat x = x : repeat x
+iterate f x = x : iterate f (f x)
+length [] = 0
+length (_:xs) = 1 + length xs
+map _ [] = []
+map f (x:xs) = f x : map f xs
+filter _ [] = []
+filter p (x:xs) = if p x then x : filter p xs else filter p xs
+zipWith _ [] _ = []
+zipWith _ _ [] = []
+zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
+fibs = 0 : 1 : zipWith plus fibs (tail fibs)
+plus a b = a + b
+")
+
+(define
+  hk-load-into!
+  (fn
+    (env src)
+    (let ((ast (hk-core src)))
+      (hk-register-program! ast)
+      (let
+        ((decls
+            (cond
+              ((= (first ast) "program") (nth ast 1))
+              ((= (first ast) "module") (nth ast 4))
+              (:else (list)))))
+        (hk-bind-decls! env decls)))))
+
+(define
+  hk-init-env
+  (fn
+    ()
+    (let ((env (dict)))
+      (dict-set! env "otherwise" hk-true)
+      (dict-set!
+        env
+        "error"
+        (hk-mk-builtin
+          "error"
+          (fn (msg) (raise (str "*** Exception: " msg)))
+          1))
+      (dict-set!
+        env
+        "not"
+        (hk-mk-builtin
+          "not"
+          (fn (b) (hk-of-bool (not (hk-truthy? b))))
+          1))
+      (dict-set!
+        env
+        "id"
+        (hk-mk-builtin "id" (fn (x) x) 1))
+      ;; `seq a b` — strict in `a`, lazy in `b`. Forces `a` to WHNF
+      ;; and returns `b` unchanged (still a thunk if it was one).
+      (dict-set!
+        env
+        "seq"
+        (hk-mk-lazy-builtin
+          "seq"
+          (fn (a b) (do (hk-force a) b))
+          2))
+      ;; `deepseq a b` — like seq but forces `a` to normal form.
+      (dict-set!
+        env
+        "deepseq"
+        (hk-mk-lazy-builtin
+          "deepseq"
+          (fn (a b) (do (hk-deep-force a) b))
+          2))
+      ;; ── Stub IO monad ─────────────────────────────────────
+      ;; IO actions are tagged values `("IO" payload)`; `>>=` and
+      ;; `>>` chain them. Lazy in the action arguments so do-blocks
+      ;; can be deeply structured without forcing the whole chain
+      ;; up front.
+      (dict-set!
+        env
+        "return"
+        (hk-mk-lazy-builtin
+          "return"
+          (fn (x) (list "IO" x))
+          1))
+      (dict-set!
+        env
+        ">>="
+        (hk-mk-lazy-builtin
+          ">>="
+          (fn (m f)
+            (let ((io-val (hk-force m)))
+              (cond
+                ((and
+                    (list? io-val)
+                    (= (first io-val) "IO"))
+                  (hk-apply (hk-force f) (nth io-val 1)))
+                (:else
+                  (raise "(>>=): left side is not an IO action")))))
+          2))
+      (dict-set!
+        env
+        ">>"
+        (hk-mk-lazy-builtin
+          ">>"
+          (fn (m n)
+            (let ((io-val (hk-force m)))
+              (cond
+                ((and
+                    (list? io-val)
+                    (= (first io-val) "IO"))
+                  (hk-force n))
+                (:else
+                  (raise "(>>): left side is not an IO action")))))
+          2))
+      ;; Operators as first-class values
+      (dict-set! env "+" (hk-make-binop-builtin "+" "+"))
+      (dict-set! env "-" (hk-make-binop-builtin "-" "-"))
+      (dict-set! env "*" (hk-make-binop-builtin "*" "*"))
+      (dict-set! env "/" (hk-make-binop-builtin "/" "/"))
+      (dict-set! env "==" (hk-make-binop-builtin "==" "=="))
+      (dict-set! env "/=" (hk-make-binop-builtin "/=" "/="))
+      (dict-set! env "<" (hk-make-binop-builtin "<" "<"))
+      (dict-set! env "<=" (hk-make-binop-builtin "<=" "<="))
+      (dict-set! env ">" (hk-make-binop-builtin ">" ">"))
+      (dict-set! env ">=" (hk-make-binop-builtin ">=" ">="))
+      (dict-set! env "&&" (hk-make-binop-builtin "&&" "&&"))
+      (dict-set! env "||" (hk-make-binop-builtin "||" "||"))
+      (dict-set! env "++" (hk-make-binop-builtin "++" "++"))
+      (hk-load-into! env hk-prelude-src)
+      env)))
+
+(define
+  hk-bind-decls!
+  (fn
+    (env decls)
+    (let
+      ((groups (dict))
+        (group-order (list))
+        (pat-binds (list)))
+      ;; Pass 1: collect fun-clause groups by name; track first-seen
+      ;; order so pass 3 can evaluate 0-arity bodies in source order
+      ;; (forward references to other 0-arity definitions still need
+      ;; the earlier name to be bound first).
+      (for-each
+        (fn (d)
+          (cond
+            ((= (first d) "fun-clause")
+              (let
+                ((name (nth d 1)))
+                (when (not (has-key? groups name))
+                  (append! group-order name))
+                (dict-set!
+                  groups
+                  name
+                  (append
+                    (if
+                      (has-key? groups name)
+                      (get groups name)
+                      (list))
+                    (list (list (nth d 2) (nth d 3)))))
+                (when
+                  (not (has-key? env name))
+                  (dict-set! env name nil))))
+            ((or (= (first d) "bind") (= (first d) "pat-bind"))
+              (append! pat-binds d))
+            (:else nil)))
+        decls)
+      ;; Pass 2: install multifuns (arity > 0) — order doesn't matter
+      ;; because they're closures; collect 0-arity names in source
+      ;; order for pass 3.
+      (let ((zero-arity (list)))
+        (for-each
+          (fn (name)
+            (let ((clauses (get groups name)))
+              (let ((arity (len (first (first clauses)))))
+                (cond
+                  ((> arity 0)
+                    (dict-set!
+                      env
+                      name
+                      (hk-mk-multifun arity clauses env)))
+                  (:else (append! zero-arity name))))))
+          group-order)
+        ;; Pass 3: evaluate 0-arity bodies and pat-binds in source
+        ;; order — forward references to a later 0-arity name will
+        ;; still see its placeholder (nil) and fail noisily, but the
+        ;; common case of a top-down program works.
+        (for-each
+          (fn (name)
+            (let ((clauses (get groups name)))
+              (dict-set!
+                env
+                name
+                (hk-eval (first (rest (first clauses))) env))))
+          zero-arity)
+        (for-each
+          (fn (d)
+            (let ((pat (nth d 1)) (body (nth d 2)))
+              (let ((val (hk-eval body env)))
+                (let ((res (hk-match pat val env)))
+                  (cond
+                    ((nil? res)
+                      (raise "top-level pattern bind failure"))
+                    (:else (hk-extend-env-with-match! env res)))))))
+          pat-binds))
+      env)))
+
+(define
+  hk-eval-program
+  (fn
+    (ast)
+    (cond
+      ((nil? ast) (raise "eval-program: nil ast"))
+      ((not (list? ast)) (raise "eval-program: not a list"))
+      (:else
+        (do
+          (hk-register-program! ast)
+          (let ((env (hk-init-env)))
+            (let
+              ((decls
+                  (cond
+                    ((= (first ast) "program") (nth ast 1))
+                    ((= (first ast) "module") (nth ast 4))
+                    (:else (raise "eval-program: bad shape")))))
+              (hk-bind-decls! env decls))))))))
+
+;; ── Source-level convenience ────────────────────────────────
+(define
+  hk-run
+  (fn
+    (src)
+    (let ((env (hk-eval-program (hk-core src))))
+      (cond
+        ((has-key? env "main") (get env "main"))
+        (:else env)))))
+
+(define
+  hk-eval-expr-source
+  (fn
+    (src)
+    (hk-deep-force (hk-eval (hk-core-expr src) (hk-init-env)))))

lib/haskell/layout.sx

@@ -0,0 +1,329 @@
+;; Haskell 98 layout algorithm (§10.3).
+;;
+;; Consumes the raw token stream produced by hk-tokenize and inserts
+;; virtual braces / semicolons (types vlbrace / vrbrace / vsemi) based
+;; on indentation. Newline tokens are consumed and stripped.
+;;
+;;   (hk-layout (hk-tokenize src))  →  tokens-with-virtual-layout
+
+;; ── Pre-pass ──────────────────────────────────────────────────────
+;;
+;; Walks the raw token list and emits an augmented stream containing
+;; two fresh pseudo-tokens:
+;;
+;;   {:type "layout-open"   :col N :keyword K}
+;;     At stream start (K = "<module>") unless the first real token is
+;;     `module` or `{`. Also immediately after every `let` / `where` /
+;;     `do` / `of` whose following token is NOT `{`. N is the column
+;;     of the token that follows.
+;;
+;;   {:type "layout-indent" :col N}
+;;     Before any token whose line is strictly greater than the line
+;;     of the previously emitted real token, EXCEPT when that token
+;;     is already preceded by a layout-open (Haskell 98 §10.3 note 3).
+;;
+;; Raw newline tokens are dropped.
+
+(define
+  hk-layout-keyword?
+  (fn
+    (tok)
+    (and
+      (= (get tok "type") "reserved")
+      (or
+        (= (get tok "value") "let")
+        (= (get tok "value") "where")
+        (= (get tok "value") "do")
+        (= (get tok "value") "of")))))
+
+(define
+  hk-layout-pre
+  (fn
+    (tokens)
+    (let
+      ((result (list))
+        (n (len tokens))
+        (i 0)
+        (prev-line -1)
+        (first-real-emitted false)
+        (suppress-next-indent false))
+      (define
+        hk-next-real-idx
+        (fn
+          (start)
+          (let
+            ((j start))
+            (define
+              hk-nri-loop
+              (fn
+                ()
+                (when
+                  (and
+                    (< j n)
+                    (= (get (nth tokens j) "type") "newline"))
+                  (do (set! j (+ j 1)) (hk-nri-loop)))))
+            (hk-nri-loop)
+            j)))
+      (define
+        hk-pre-step
+        (fn
+          ()
+          (when
+            (< i n)
+            (let
+              ((tok (nth tokens i)) (ty (get tok "type")))
+              (cond
+                ((= ty "newline") (do (set! i (+ i 1)) (hk-pre-step)))
+                (:else
+                  (do
+                    (when
+                      (not first-real-emitted)
+                      (do
+                        (set! first-real-emitted true)
+                        (when
+                          (not
+                            (or
+                              (and
+                                (= ty "reserved")
+                                (= (get tok "value") "module"))
+                              (= ty "lbrace")))
+                          (do
+                            (append!
+                              result
+                              {:type "layout-open"
+                                :col (get tok "col")
+                                :keyword "<module>"
+                                :line (get tok "line")})
+                            (set! suppress-next-indent true)))))
+                    (when
+                      (and
+                        (>= prev-line 0)
+                        (> (get tok "line") prev-line)
+                        (not suppress-next-indent))
+                      (append!
+                        result
+                        {:type "layout-indent"
+                          :col (get tok "col")
+                          :line (get tok "line")}))
+                    (set! suppress-next-indent false)
+                    (set! prev-line (get tok "line"))
+                    (append! result tok)
+                    (when
+                      (hk-layout-keyword? tok)
+                      (let
+                        ((j (hk-next-real-idx (+ i 1))))
+                        (cond
+                          ((>= j n)
+                            (do
+                              (append!
+                                result
+                                {:type "layout-open"
+                                  :col 0
+                                  :keyword (get tok "value")
+                                  :line (get tok "line")})
+                              (set! suppress-next-indent true)))
+                          ((= (get (nth tokens j) "type") "lbrace") nil)
+                          (:else
+                            (do
+                              (append!
+                                result
+                                {:type "layout-open"
+                                  :col (get (nth tokens j) "col")
+                                  :keyword (get tok "value")
+                                  :line (get tok "line")})
+                              (set! suppress-next-indent true))))))
+                    (set! i (+ i 1))
+                    (hk-pre-step))))))))
+      (hk-pre-step)
+      result)))
+
+;; ── Main pass: L algorithm ────────────────────────────────────────
+;;
+;; Stack is a list; the head is the top of stack. Each entry is
+;; either the keyword :explicit (pushed by an explicit `{`) or a dict
+;; {:col N :keyword K} pushed by a layout-open marker.
+;;
+;; Rules (following Haskell 98 §10.3):
+;;
+;;   layout-open(n)  vs stack:
+;;     empty or explicit top                 → push n; emit {
+;;     n > top-col                           → push n; emit {
+;;     otherwise                             → emit { }; retry as indent(n)
+;;
+;;   layout-indent(n) vs stack:
+;;     empty or explicit top                 → drop
+;;     n == top-col                          → emit ;
+;;     n <  top-col                          → emit }; pop; recurse
+;;     n >  top-col                          → drop
+;;
+;;   lbrace                                  → push :explicit; emit {
+;;   rbrace                                  → pop if :explicit; emit }
+;;   `in` with implicit let on top           → emit }; pop; emit in
+;;   any other token                         → emit
+;;
+;; EOF: emit } for every remaining implicit context.
+
+(define
+  hk-layout-L
+  (fn
+    (pre-toks)
+    (let
+      ((result (list))
+        (stack (list))
+        (n (len pre-toks))
+        (i 0))
+      (define hk-emit (fn (t) (append! result t)))
+      (define
+        hk-indent-at
+        (fn
+          (col line)
+          (cond
+            ((or (empty? stack) (= (first stack) :explicit)) nil)
+            (:else
+              (let
+                ((top-col (get (first stack) "col")))
+                (cond
+                  ((= col top-col)
+                    (hk-emit
+                      {:type "vsemi" :value ";" :line line :col col}))
+                  ((< col top-col)
+                    (do
+                      (hk-emit
+                        {:type "vrbrace" :value "}" :line line :col col})
+                      (set! stack (rest stack))
+                      (hk-indent-at col line)))
+                  (:else nil)))))))
+      (define
+        hk-open-at
+        (fn
+          (col keyword line)
+          (cond
+            ((and
+                (> col 0)
+                (or
+                  (empty? stack)
+                  (= (first stack) :explicit)
+                  (> col (get (first stack) "col"))))
+              (do
+                (hk-emit
+                  {:type "vlbrace" :value "{" :line line :col col})
+                (set! stack (cons {:col col :keyword keyword} stack))))
+            (:else
+              (do
+                (hk-emit
+                  {:type "vlbrace" :value "{" :line line :col col})
+                (hk-emit
+                  {:type "vrbrace" :value "}" :line line :col col})
+                (hk-indent-at col line))))))
+      (define
+        hk-close-eof
+        (fn
+          ()
+          (when
+            (and
+              (not (empty? stack))
+              (not (= (first stack) :explicit)))
+            (do
+              (hk-emit {:type "vrbrace" :value "}" :line 0 :col 0})
+              (set! stack (rest stack))
+              (hk-close-eof)))))
+      ;; Peek past further layout-indent / layout-open markers to find
+      ;; the next real token's value when its type is `reserved`.
+      ;; Returns nil if no such token.
+      (define
+        hk-peek-next-reserved
+        (fn
+          (start)
+          (let ((j (+ start 1)) (found nil) (done false))
+            (define
+              hk-pnr-loop
+              (fn
+                ()
+                (when
+                  (and (not done) (< j n))
+                  (let
+                    ((t (nth pre-toks j)) (ty (get t "type")))
+                    (cond
+                      ((or
+                          (= ty "layout-indent")
+                          (= ty "layout-open"))
+                        (do (set! j (+ j 1)) (hk-pnr-loop)))
+                      ((= ty "reserved")
+                        (do (set! found (get t "value")) (set! done true)))
+                      (:else (set! done true)))))))
+            (hk-pnr-loop)
+            found)))
+      (define
+        hk-layout-step
+        (fn
+          ()
+          (when
+            (< i n)
+            (let
+              ((tok (nth pre-toks i)) (ty (get tok "type")))
+              (cond
+                ((= ty "eof")
+                  (do
+                    (hk-close-eof)
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((= ty "layout-open")
+                  (do
+                    (hk-open-at
+                      (get tok "col")
+                      (get tok "keyword")
+                      (get tok "line"))
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((= ty "layout-indent")
+                  (cond
+                    ((= (hk-peek-next-reserved i) "in")
+                      (do (set! i (+ i 1)) (hk-layout-step)))
+                    (:else
+                      (do
+                        (hk-indent-at (get tok "col") (get tok "line"))
+                        (set! i (+ i 1))
+                        (hk-layout-step)))))
+                ((= ty "lbrace")
+                  (do
+                    (set! stack (cons :explicit stack))
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((= ty "rbrace")
+                  (do
+                    (when
+                      (and
+                        (not (empty? stack))
+                        (= (first stack) :explicit))
+                      (set! stack (rest stack)))
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((and
+                    (= ty "reserved")
+                    (= (get tok "value") "in")
+                    (not (empty? stack))
+                    (not (= (first stack) :explicit))
+                    (= (get (first stack) "keyword") "let"))
+                  (do
+                    (hk-emit
+                      {:type "vrbrace"
+                        :value "}"
+                        :line (get tok "line")
+                        :col (get tok "col")})
+                    (set! stack (rest stack))
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                (:else
+                  (do
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step))))))))
+      (hk-layout-step)
+      (hk-close-eof)
+      result)))
+
+(define hk-layout (fn (tokens) (hk-layout-L (hk-layout-pre tokens))))

lib/haskell/match.sx

@@ -0,0 +1,201 @@
+;; Value-level pattern matching.
+;;
+;; Constructor values are tagged lists whose first element is the
+;; constructor name (a string). Tuples use the special tag "Tuple".
+;; Lists use the spine of `:` cons and `[]` nil.
+;;
+;;   Just 5         →  ("Just" 5)
+;;   Nothing        →  ("Nothing")
+;;   (1, 2)         →  ("Tuple" 1 2)
+;;   [1, 2]         →  (":" 1 (":" 2 ("[]")))
+;;   ()             →  ("()")
+;;
+;; Primitive values (numbers, strings, chars) are stored raw.
+;;
+;; The matcher takes a pattern AST node, a value, and an environment
+;; dict; it returns an extended dict on success, or `nil` on failure.
+
+;; ── Value builders ──────────────────────────────────────────
+(define
+  hk-mk-con
+  (fn
+    (cname args)
+    (let ((result (list cname)))
+      (for-each (fn (a) (append! result a)) args)
+      result)))
+
+(define
+  hk-mk-tuple
+  (fn
+    (items)
+    (let ((result (list "Tuple")))
+      (for-each (fn (x) (append! result x)) items)
+      result)))
+
+(define hk-mk-nil (fn () (list "[]")))
+
+(define hk-mk-cons (fn (h t) (list ":" h t)))
+
+(define
+  hk-mk-list
+  (fn
+    (items)
+    (cond
+      ((empty? items) (hk-mk-nil))
+      (:else
+        (hk-mk-cons (first items) (hk-mk-list (rest items)))))))
+
+;; ── Predicates / accessors on constructor values ───────────
+(define
+  hk-is-con-val?
+  (fn
+    (v)
+    (and
+      (list? v)
+      (not (empty? v))
+      (string? (first v)))))
+
+(define hk-val-con-name (fn (v) (first v)))
+
+(define hk-val-con-args (fn (v) (rest v)))
+
+;; ── The matcher ────────────────────────────────────────────
+;;
+;; Pattern match forces the scrutinee to WHNF before inspecting it
+;; — except for `p-wild`, `p-var`, and `p-lazy`, which never need
+;; to look at the value. Args of constructor / tuple / list values
+;; remain thunked (they're forced only when their own pattern needs
+;; to inspect them, recursively).
+(define
+  hk-match
+  (fn
+    (pat val env)
+    (cond
+      ((not (list? pat)) nil)
+      ((empty? pat) nil)
+      (:else
+        (let
+          ((tag (first pat)))
+          (cond
+            ((= tag "p-wild") env)
+            ((= tag "p-var") (assoc env (nth pat 1) val))
+            ((= tag "p-lazy") (hk-match (nth pat 1) val env))
+            ((= tag "p-as")
+              (let
+                ((res (hk-match (nth pat 2) val env)))
+                (cond
+                  ((nil? res) nil)
+                  (:else (assoc res (nth pat 1) val)))))
+            (:else
+              (let ((fv (hk-force val)))
+                (cond
+                  ((= tag "p-int")
+                    (if
+                      (and (number? fv) (= fv (nth pat 1)))
+                      env
+                      nil))
+                  ((= tag "p-float")
+                    (if
+                      (and (number? fv) (= fv (nth pat 1)))
+                      env
+                      nil))
+                  ((= tag "p-string")
+                    (if
+                      (and (string? fv) (= fv (nth pat 1)))
+                      env
+                      nil))
+                  ((= tag "p-char")
+                    (if
+                      (and (string? fv) (= fv (nth pat 1)))
+                      env
+                      nil))
+                  ((= tag "p-con")
+                    (let
+                      ((pat-name (nth pat 1)) (pat-args (nth pat 2)))
+                      (cond
+                        ((not (hk-is-con-val? fv)) nil)
+                        ((not (= (hk-val-con-name fv) pat-name)) nil)
+                        (:else
+                          (let
+                            ((val-args (hk-val-con-args fv)))
+                            (cond
+                              ((not (= (len pat-args) (len val-args)))
+                                nil)
+                              (:else
+                                (hk-match-all
+                                  pat-args
+                                  val-args
+                                  env))))))))
+                  ((= tag "p-tuple")
+                    (let
+                      ((items (nth pat 1)))
+                      (cond
+                        ((not (hk-is-con-val? fv)) nil)
+                        ((not (= (hk-val-con-name fv) "Tuple")) nil)
+                        ((not (= (len (hk-val-con-args fv)) (len items)))
+                          nil)
+                        (:else
+                          (hk-match-all
+                            items
+                            (hk-val-con-args fv)
+                            env)))))
+                  ((= tag "p-list")
+                    (hk-match-list-pat (nth pat 1) fv env))
+                  (:else nil))))))))))
+
+(define
+  hk-match-all
+  (fn
+    (pats vals env)
+    (cond
+      ((empty? pats) env)
+      (:else
+        (let
+          ((res (hk-match (first pats) (first vals) env)))
+          (cond
+            ((nil? res) nil)
+            (:else
+              (hk-match-all (rest pats) (rest vals) res))))))))
+
+(define
+  hk-match-list-pat
+  (fn
+    (items val env)
+    (let ((fv (hk-force val)))
+      (cond
+        ((empty? items)
+          (if
+            (and
+              (hk-is-con-val? fv)
+              (= (hk-val-con-name fv) "[]"))
+            env
+            nil))
+        (:else
+          (cond
+            ((not (hk-is-con-val? fv)) nil)
+            ((not (= (hk-val-con-name fv) ":")) nil)
+            (:else
+              (let
+                ((args (hk-val-con-args fv)))
+                (let
+                  ((h (first args)) (t (first (rest args))))
+                  (let
+                    ((res (hk-match (first items) h env)))
+                    (cond
+                      ((nil? res) nil)
+                      (:else
+                        (hk-match-list-pat
+                          (rest items)
+                          t
+                          res)))))))))))))
+
+;; ── Convenience: parse a pattern from source for tests ─────
+;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
+;; to extract a pattern AST.)
+(define
+  hk-parse-pat-source
+  (fn
+    (src)
+    (let
+      ((expr (hk-parse (str "case 0 of " src " -> 0"))))
+      (nth (nth (nth expr 2) 0) 1))))

lib/haskell/runtime.sx

@@ -0,0 +1,130 @@
+;; Haskell runtime: constructor registry.
+;;
+;; A mutable dict keyed by constructor name (e.g. "Just", "[]") with
+;; entries of shape  {:arity N :type TYPE-NAME-STRING}.
+;; Populated by ingesting `data` / `newtype` decls from parsed ASTs.
+;; Pre-registers a small set of constructors tied to Haskell syntactic
+;; forms (Bool, list, unit) — every nontrivial program depends on
+;; these, and the parser/desugar pipeline emits them as (:var "True")
+;; etc. without a corresponding `data` decl.
+
+(define hk-constructors (dict))
+
+(define
+  hk-register-con!
+  (fn
+    (cname arity type-name)
+    (dict-set!
+      hk-constructors
+      cname
+      {:arity arity :type type-name})))
+
+(define hk-is-con? (fn (name) (has-key? hk-constructors name)))
+
+(define
+  hk-con-arity
+  (fn
+    (name)
+    (if
+      (has-key? hk-constructors name)
+      (get (get hk-constructors name) "arity")
+      nil)))
+
+(define
+  hk-con-type
+  (fn
+    (name)
+    (if
+      (has-key? hk-constructors name)
+      (get (get hk-constructors name) "type")
+      nil)))
+
+(define hk-con-names (fn () (keys hk-constructors)))
+
+;; ── Registration from AST ────────────────────────────────────
+;; (:data NAME TVARS ((:con-def CNAME FIELDS) …))
+(define
+  hk-register-data!
+  (fn
+    (data-node)
+    (let
+      ((type-name (nth data-node 1))
+        (cons-list (nth data-node 3)))
+      (for-each
+        (fn
+          (cd)
+          (hk-register-con!
+            (nth cd 1)
+            (len (nth cd 2))
+            type-name))
+        cons-list))))
+
+;; (:newtype NAME TVARS CNAME FIELD)
+(define
+  hk-register-newtype!
+  (fn
+    (nt-node)
+    (hk-register-con!
+      (nth nt-node 3)
+      1
+      (nth nt-node 1))))
+
+;; Walk a decls list, registering every `data` / `newtype` decl.
+(define
+  hk-register-decls!
+  (fn
+    (decls)
+    (for-each
+      (fn
+        (d)
+        (cond
+          ((and
+              (list? d)
+              (not (empty? d))
+              (= (first d) "data"))
+            (hk-register-data! d))
+          ((and
+              (list? d)
+              (not (empty? d))
+              (= (first d) "newtype"))
+            (hk-register-newtype! d))
+          (:else nil)))
+      decls)))
+
+(define
+  hk-register-program!
+  (fn
+    (ast)
+    (cond
+      ((nil? ast) nil)
+      ((not (list? ast)) nil)
+      ((empty? ast) nil)
+      ((= (first ast) "program")
+        (hk-register-decls! (nth ast 1)))
+      ((= (first ast) "module")
+        (hk-register-decls! (nth ast 4)))
+      (:else nil))))
+
+;; Convenience: source → AST → desugar → register.
+(define
+  hk-load-source!
+  (fn (src) (hk-register-program! (hk-core src))))
+
+;; ── Built-in constructors pre-registered ─────────────────────
+;; Bool — used implicitly by `if`, comparison operators.
+(hk-register-con! "True" 0 "Bool")
+(hk-register-con! "False" 0 "Bool")
+;; List — used by list literals, range syntax, and cons operator.
+(hk-register-con! "[]" 0 "List")
+(hk-register-con! ":" 2 "List")
+;; Unit — produced by empty parens `()`.
+(hk-register-con! "()" 0 "Unit")
+;; Standard Prelude types — pre-registered so expression-level
+;; programs can use them without a `data` decl.
+(hk-register-con! "Nothing" 0 "Maybe")
+(hk-register-con! "Just"    1 "Maybe")
+(hk-register-con! "Left"    1 "Either")
+(hk-register-con! "Right"   1 "Either")
+(hk-register-con! "LT" 0 "Ordering")
+(hk-register-con! "EQ" 0 "Ordering")
+(hk-register-con! "GT" 0 "Ordering")

lib/haskell/test.sh

@@ -46,6 +46,13 @@ for FILE in "${FILES[@]}"; do
   cat > "$TMPFILE" <<EPOCHS
 (epoch 1)
 (load "lib/haskell/tokenizer.sx")
+(load "lib/haskell/layout.sx")
+(load "lib/haskell/parser.sx")
+(load "lib/haskell/desugar.sx")
+(load "lib/haskell/runtime.sx")
+(load "lib/haskell/match.sx")
+(load "lib/haskell/eval.sx")
+(load "lib/haskell/testlib.sx")
 (epoch 2)
 (load "$FILE")
 (epoch 3)
@@ -81,6 +88,13 @@ EPOCHS
     cat > "$TMPFILE2" <<EPOCHS
 (epoch 1)
 (load "lib/haskell/tokenizer.sx")
+(load "lib/haskell/layout.sx")
+(load "lib/haskell/parser.sx")
+(load "lib/haskell/desugar.sx")
+(load "lib/haskell/runtime.sx")
+(load "lib/haskell/match.sx")
+(load "lib/haskell/eval.sx")
+(load "lib/haskell/testlib.sx")
 (epoch 2)
 (load "$FILE")
 (epoch 3)

lib/haskell/testlib.sx

@@ -0,0 +1,58 @@
+;; Shared test harness for Haskell-on-SX tests.
+;; Each test file expects hk-test / hk-deep=? / counters to already be bound.
+
+(define
+  hk-deep=?
+  (fn
+    (a b)
+    (cond
+      ((= a b) true)
+      ((and (dict? a) (dict? b))
+        (let
+          ((ak (keys a)) (bk (keys b)))
+          (if
+            (not (= (len ak) (len bk)))
+            false
+            (every?
+              (fn
+                (k)
+                (and (has-key? b k) (hk-deep=? (get a k) (get b k))))
+              ak))))
+      ((and (list? a) (list? b))
+        (if
+          (not (= (len a) (len b)))
+          false
+          (let
+            ((i 0) (ok true))
+            (define
+              hk-de-loop
+              (fn
+                ()
+                (when
+                  (and ok (< i (len a)))
+                  (do
+                    (when
+                      (not (hk-deep=? (nth a i) (nth b i)))
+                      (set! ok false))
+                    (set! i (+ i 1))
+                    (hk-de-loop)))))
+            (hk-de-loop)
+            ok)))
+      (:else false))))
+
+(define hk-test-pass 0)
+(define hk-test-fail 0)
+(define hk-test-fails (list))
+
+(define
+  hk-test
+  (fn
+    (name actual expected)
+    (if
+      (hk-deep=? actual expected)
+      (set! hk-test-pass (+ hk-test-pass 1))
+      (do
+        (set! hk-test-fail (+ hk-test-fail 1))
+        (append!
+          hk-test-fails
+          {:actual actual :expected expected :name name})))))

lib/haskell/tests/desugar.sx

@@ -0,0 +1,305 @@
+;; Desugar tests — surface AST → core AST.
+;;   :guarded   →  nested :if
+;;   :where     →  :let
+;;   :list-comp →  concatMap-based tree
+
+(define
+  hk-prog
+  (fn (&rest decls) (list :program decls)))
+
+;; ── Guards → if ──
+(hk-test
+  "two-way guarded rhs"
+  (hk-desugar (hk-parse-top "abs x | x < 0 = - x\n      | otherwise = x"))
+  (hk-prog
+    (list
+      :fun-clause
+      "abs"
+      (list (list :p-var "x"))
+      (list
+        :if
+        (list :op "<" (list :var "x") (list :int 0))
+        (list :neg (list :var "x"))
+        (list
+          :if
+          (list :var "otherwise")
+          (list :var "x")
+          (list
+            :app
+            (list :var "error")
+            (list :string "Non-exhaustive guards")))))))
+
+(hk-test
+  "three-way guarded rhs"
+  (hk-desugar
+    (hk-parse-top "sign n | n > 0 = 1\n       | n < 0 = -1\n       | otherwise = 0"))
+  (hk-prog
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-var "n"))
+      (list
+        :if
+        (list :op ">" (list :var "n") (list :int 0))
+        (list :int 1)
+        (list
+          :if
+          (list :op "<" (list :var "n") (list :int 0))
+          (list :neg (list :int 1))
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards"))))))))
+
+(hk-test
+  "case-alt guards desugared too"
+  (hk-desugar
+    (hk-parse "case x of\n  Just y | y > 0 -> y\n         | otherwise -> 0\n  Nothing -> -1"))
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list
+          :if
+          (list :op ">" (list :var "y") (list :int 0))
+          (list :var "y")
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards")))))
+      (list
+        :alt
+        (list :p-con "Nothing" (list))
+        (list :neg (list :int 1))))))
+
+;; ── Where → let ──
+(hk-test
+  "where with single binding"
+  (hk-desugar (hk-parse-top "f x = y\n  where y = x + 1"))
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :let
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1))))
+        (list :var "y")))))
+
+(hk-test
+  "where with two bindings"
+  (hk-desugar
+    (hk-parse-top "f x = y + z\n  where y = x + 1\n        z = x - 1"))
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :let
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1)))
+          (list
+            :fun-clause
+            "z"
+            (list)
+            (list :op "-" (list :var "x") (list :int 1))))
+        (list :op "+" (list :var "y") (list :var "z"))))))
+
+(hk-test
+  "guards + where — guarded body inside let"
+  (hk-desugar
+    (hk-parse-top "f x | x > 0 = y\n    | otherwise = 0\n  where y = 99"))
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :let
+        (list (list :fun-clause "y" (list) (list :int 99)))
+        (list
+          :if
+          (list :op ">" (list :var "x") (list :int 0))
+          (list :var "y")
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards"))))))))
+
+;; ── List comprehensions → concatMap / if / let ──
+(hk-test
+  "list-comp: single generator"
+  (hk-core-expr "[x | x <- xs]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list :list (list (list :var "x")))))
+    (list :var "xs")))
+
+(hk-test
+  "list-comp: generator then guard"
+  (hk-core-expr "[x * 2 | x <- xs, x > 0]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list
+          :if
+          (list :op ">" (list :var "x") (list :int 0))
+          (list
+            :list
+            (list (list :op "*" (list :var "x") (list :int 2))))
+          (list :list (list)))))
+    (list :var "xs")))
+
+(hk-test
+  "list-comp: generator then let"
+  (hk-core-expr "[y | x <- xs, let y = x + 1]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list
+          :let
+          (list
+            (list
+              :bind
+              (list :p-var "y")
+              (list :op "+" (list :var "x") (list :int 1))))
+          (list :list (list (list :var "y"))))))
+    (list :var "xs")))
+
+(hk-test
+  "list-comp: two generators (nested concatMap)"
+  (hk-core-expr "[(x, y) | x <- xs, y <- ys]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list
+          :app
+          (list
+            :app
+            (list :var "concatMap")
+            (list
+              :lambda
+              (list (list :p-var "y"))
+              (list
+                :list
+                (list
+                  (list
+                    :tuple
+                    (list (list :var "x") (list :var "y")))))))
+          (list :var "ys"))))
+    (list :var "xs")))
+
+;; ── Pass-through cases ──
+(hk-test
+  "plain int literal unchanged"
+  (hk-core-expr "42")
+  (list :int 42))
+
+(hk-test
+  "lambda + if passes through"
+  (hk-core-expr "\\x -> if x > 0 then x else - x")
+  (list
+    :lambda
+    (list (list :p-var "x"))
+    (list
+      :if
+      (list :op ">" (list :var "x") (list :int 0))
+      (list :var "x")
+      (list :neg (list :var "x")))))
+
+(hk-test
+  "simple fun-clause (no guards/where) passes through"
+  (hk-desugar (hk-parse-top "id x = x"))
+  (hk-prog
+    (list
+      :fun-clause
+      "id"
+      (list (list :p-var "x"))
+      (list :var "x"))))
+
+(hk-test
+  "data decl passes through"
+  (hk-desugar (hk-parse-top "data Maybe a = Nothing | Just a"))
+  (hk-prog
+    (list
+      :data
+      "Maybe"
+      (list "a")
+      (list
+        (list :con-def "Nothing" (list))
+        (list :con-def "Just" (list (list :t-var "a")))))))
+
+(hk-test
+  "module header passes through, body desugared"
+  (hk-desugar
+    (hk-parse-top "module M where\nf x | x > 0 = 1\n    | otherwise = 0"))
+  (list
+    :module
+    "M"
+    nil
+    (list)
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list
+          :if
+          (list :op ">" (list :var "x") (list :int 0))
+          (list :int 1)
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards"))))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/do-io.sx

@@ -0,0 +1,117 @@
+;; do-notation + stub IO monad. Desugaring is per Haskell 98 §3.14:
+;;   do { e ; ss }      = e >> do { ss }
+;;   do { p <- e ; ss } = e >>= \p -> do { ss }
+;;   do { let ds ; ss } = let ds in do { ss }
+;;   do { e }           = e
+;; The IO type is just `("IO" payload)` for now — no real side
+;; effects yet. `return`, `>>=`, `>>` are built-ins.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+;; ── Single-statement do ──
+(hk-test
+  "do with a single expression"
+  (hk-eval-expr-source "do { return 5 }")
+  (list "IO" 5))
+
+(hk-test
+  "return wraps any expression"
+  (hk-eval-expr-source "return (1 + 2 * 3)")
+  (list "IO" 7))
+
+;; ── Bind threads results ──
+(hk-test
+  "single bind"
+  (hk-eval-expr-source
+    "do { x <- return 5 ; return (x + 1) }")
+  (list "IO" 6))
+
+(hk-test
+  "two binds"
+  (hk-eval-expr-source
+    "do\n  x <- return 5\n  y <- return 7\n  return (x + y)")
+  (list "IO" 12))
+
+(hk-test
+  "three binds — accumulating"
+  (hk-eval-expr-source
+    "do\n  a <- return 1\n  b <- return 2\n  c <- return 3\n  return (a + b + c)")
+  (list "IO" 6))
+
+;; ── Mixing >> and >>= ──
+(hk-test
+  ">> sequencing — last wins"
+  (hk-eval-expr-source
+    "do\n  return 1\n  return 2\n  return 3")
+  (list "IO" 3))
+
+(hk-test
+  ">> then >>= — last bind wins"
+  (hk-eval-expr-source
+    "do\n  return 99\n  x <- return 5\n  return x")
+  (list "IO" 5))
+
+;; ── do-let ──
+(hk-test
+  "do-let single binding"
+  (hk-eval-expr-source
+    "do\n  let x = 3\n  return (x * 2)")
+  (list "IO" 6))
+
+(hk-test
+  "do-let multi-bind, used after"
+  (hk-eval-expr-source
+    "do\n  let x = 4\n      y = 5\n  return (x * y)")
+  (list "IO" 20))
+
+(hk-test
+  "do-let interleaved with bind"
+  (hk-eval-expr-source
+    "do\n  x <- return 10\n  let y = x + 1\n  return (x * y)")
+  (list "IO" 110))
+
+;; ── Bind + pattern ──
+(hk-test
+  "bind to constructor pattern"
+  (hk-eval-expr-source
+    "do\n  Just x <- return (Just 7)\n  return (x + 100)")
+  (list "IO" 107))
+
+(hk-test
+  "bind to tuple pattern"
+  (hk-eval-expr-source
+    "do\n  (a, b) <- return (3, 4)\n  return (a * b)")
+  (list "IO" 12))
+
+;; ── User-defined IO functions ──
+(hk-test
+  "do inside top-level fun"
+  (hk-prog-val
+    "addM x y = do\n  a <- return x\n  b <- return y\n  return (a + b)\nresult = addM 5 6"
+    "result")
+  (list "IO" 11))
+
+(hk-test
+  "nested do"
+  (hk-eval-expr-source
+    "do\n  x <- do { y <- return 3 ; return (y + 1) }\n  return (x * 2)")
+  (list "IO" 8))
+
+;; ── (>>=) and (>>) used directly as functions ──
+(hk-test
+  ">>= used directly"
+  (hk-eval-expr-source
+    "(return 4) >>= (\\x -> return (x + 100))")
+  (list "IO" 104))
+
+(hk-test
+  ">> used directly"
+  (hk-eval-expr-source
+    "(return 1) >> (return 2)")
+  (list "IO" 2))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/eval.sx

@@ -0,0 +1,278 @@
+;; Strict evaluator tests. Each test parses, desugars, and evaluates
+;; either an expression (hk-eval-expr-source) or a full program
+;; (hk-eval-program → look up a named value).
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+;; ── Literals ──
+(hk-test "int literal" (hk-eval-expr-source "42") 42)
+(hk-test "float literal" (hk-eval-expr-source "3.14") 3.14)
+(hk-test "string literal" (hk-eval-expr-source "\"hi\"") "hi")
+(hk-test "char literal" (hk-eval-expr-source "'a'") "a")
+(hk-test "negative literal" (hk-eval-expr-source "- 5") -5)
+
+;; ── Arithmetic ──
+(hk-test "addition" (hk-eval-expr-source "1 + 2") 3)
+(hk-test
+  "precedence"
+  (hk-eval-expr-source "1 + 2 * 3")
+  7)
+(hk-test
+  "parens override precedence"
+  (hk-eval-expr-source "(1 + 2) * 3")
+  9)
+(hk-test
+  "subtraction left-assoc"
+  (hk-eval-expr-source "10 - 3 - 2")
+  5)
+
+;; ── Comparison + Bool ──
+(hk-test
+  "less than is True"
+  (hk-eval-expr-source "3 < 5")
+  (list "True"))
+(hk-test
+  "equality is False"
+  (hk-eval-expr-source "1 == 2")
+  (list "False"))
+(hk-test
+  "&& shortcuts"
+  (hk-eval-expr-source "(1 == 1) && (2 == 2)")
+  (list "True"))
+
+;; ── if / otherwise ──
+(hk-test
+  "if True"
+  (hk-eval-expr-source "if True then 1 else 2")
+  1)
+(hk-test
+  "if comparison branch"
+  (hk-eval-expr-source "if 5 > 3 then \"yes\" else \"no\"")
+  "yes")
+(hk-test "otherwise is True" (hk-eval-expr-source "otherwise") (list "True"))
+
+;; ── let ──
+(hk-test
+  "let single binding"
+  (hk-eval-expr-source "let x = 5 in x + 1")
+  6)
+(hk-test
+  "let two bindings"
+  (hk-eval-expr-source "let x = 1; y = 2 in x + y")
+  3)
+(hk-test
+  "let recursive: factorial 5"
+  (hk-eval-expr-source
+    "let f n = if n == 0 then 1 else n * f (n - 1) in f 5")
+  120)
+
+;; ── Lambdas ──
+(hk-test
+  "lambda apply"
+  (hk-eval-expr-source "(\\x -> x + 1) 5")
+  6)
+(hk-test
+  "lambda multi-arg"
+  (hk-eval-expr-source "(\\x y -> x * y) 3 4")
+  12)
+(hk-test
+  "lambda with constructor pattern"
+  (hk-eval-expr-source "(\\(Just x) -> x + 1) (Just 7)")
+  8)
+
+;; ── Constructors ──
+(hk-test
+  "0-arity constructor"
+  (hk-eval-expr-source "Nothing")
+  (list "Nothing"))
+(hk-test
+  "1-arity constructor applied"
+  (hk-eval-expr-source "Just 5")
+  (list "Just" 5))
+(hk-test
+  "True / False as bools"
+  (hk-eval-expr-source "True")
+  (list "True"))
+
+;; ── case ──
+(hk-test
+  "case Just"
+  (hk-eval-expr-source
+    "case Just 7 of Just x -> x ; Nothing -> 0")
+  7)
+(hk-test
+  "case Nothing"
+  (hk-eval-expr-source
+    "case Nothing of Just x -> x ; Nothing -> 99")
+  99)
+(hk-test
+  "case literal pattern"
+  (hk-eval-expr-source
+    "case 0 of 0 -> \"zero\" ; n -> \"other\"")
+  "zero")
+(hk-test
+  "case tuple"
+  (hk-eval-expr-source
+    "case (1, 2) of (a, b) -> a + b")
+  3)
+(hk-test
+  "case wildcard fallback"
+  (hk-eval-expr-source
+    "case 5 of 0 -> \"z\" ; _ -> \"nz\"")
+  "nz")
+
+;; ── List literals + cons ──
+(hk-test
+  "list literal as cons spine"
+  (hk-eval-expr-source "[1, 2, 3]")
+  (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
+(hk-test
+  "empty list literal"
+  (hk-eval-expr-source "[]")
+  (list "[]"))
+(hk-test
+  "cons via :"
+  (hk-eval-expr-source "1 : []")
+  (list ":" 1 (list "[]")))
+(hk-test
+  "++ concatenates lists"
+  (hk-eval-expr-source "[1, 2] ++ [3]")
+  (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
+
+;; ── Tuples ──
+(hk-test
+  "2-tuple"
+  (hk-eval-expr-source "(1, 2)")
+  (list "Tuple" 1 2))
+(hk-test
+  "3-tuple"
+  (hk-eval-expr-source "(\"a\", 5, True)")
+  (list "Tuple" "a" 5 (list "True")))
+
+;; ── Sections ──
+(hk-test
+  "right section (+ 1) applied"
+  (hk-eval-expr-source "(+ 1) 5")
+  6)
+(hk-test
+  "left section (10 -) applied"
+  (hk-eval-expr-source "(10 -) 4")
+  6)
+
+;; ── Multi-clause top-level functions ──
+(hk-test
+  "multi-clause: factorial"
+  (hk-prog-val
+    "fact 0 = 1\nfact n = n * fact (n - 1)\nresult = fact 6"
+    "result")
+  720)
+
+(hk-test
+  "multi-clause: list length via cons pattern"
+  (hk-prog-val
+    "len [] = 0\nlen (x:xs) = 1 + len xs\nresult = len [10, 20, 30, 40]"
+    "result")
+  4)
+
+(hk-test
+  "multi-clause: Maybe handler"
+  (hk-prog-val
+    "fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 (Just 9)"
+    "result")
+  9)
+
+(hk-test
+  "multi-clause: Maybe with default"
+  (hk-prog-val
+    "fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 Nothing"
+    "result")
+  0)
+
+;; ── User-defined data and matching ──
+(hk-test
+  "custom data with pattern match"
+  (hk-prog-val
+    "data Color = Red | Green | Blue\nname Red = \"red\"\nname Green = \"green\"\nname Blue = \"blue\"\nresult = name Green"
+    "result")
+  "green")
+
+(hk-test
+  "custom binary tree height"
+  (hk-prog-val
+    "data Tree = Leaf | Node Tree Tree\nh Leaf = 0\nh (Node l r) = 1 + max (h l) (h r)\nmax a b = if a > b then a else b\nresult = h (Node (Node Leaf Leaf) Leaf)"
+    "result")
+  2)
+
+;; ── Currying ──
+(hk-test
+  "partial application"
+  (hk-prog-val
+    "add x y = x + y\nadd5 = add 5\nresult = add5 7"
+    "result")
+  12)
+
+;; ── Higher-order ──
+(hk-test
+  "higher-order: function as arg"
+  (hk-prog-val
+    "twice f x = f (f x)\ninc x = x + 1\nresult = twice inc 10"
+    "result")
+  12)
+
+;; ── Error built-in ──
+(hk-test
+  "error short-circuits via if"
+  (hk-eval-expr-source
+    "if True then 1 else error \"unreachable\"")
+  1)
+
+;; ── Laziness: app args evaluate only when forced ──
+(hk-test
+  "second arg never forced"
+  (hk-eval-expr-source
+    "(\\x y -> x) 1 (error \"never\")")
+  1)
+
+(hk-test
+  "first arg never forced"
+  (hk-eval-expr-source
+    "(\\x y -> y) (error \"never\") 99")
+  99)
+
+(hk-test
+  "constructor argument is lazy under wildcard pattern"
+  (hk-eval-expr-source
+    "case Just (error \"deeply\") of Just _ -> 7 ; Nothing -> 0")
+  7)
+
+(hk-test
+  "lazy: const drops its second argument"
+  (hk-prog-val
+    "const x y = x\nresult = const 5 (error \"boom\")"
+    "result")
+  5)
+
+(hk-test
+  "lazy: head ignores tail"
+  (hk-prog-val
+    "myHead (x:_) = x\nresult = myHead (1 : (error \"tail\") : [])"
+    "result")
+  1)
+
+(hk-test
+  "lazy: Just on undefined evaluates only on force"
+  (hk-prog-val
+    "wrapped = Just (error \"oh no\")\nresult = case wrapped of Just _ -> True ; Nothing -> False"
+    "result")
+  (list "True"))
+
+;; ── not / id built-ins ──
+(hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
+(hk-test "not False" (hk-eval-expr-source "not False") (list "True"))
+(hk-test "id" (hk-eval-expr-source "id 42") 42)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/infinite.sx

@@ -0,0 +1,137 @@
+;; Infinite structures + Prelude tests. The lazy `:` operator builds
+;; cons cells with thunked head/tail so recursive list-defining
+;; functions terminate when only a finite prefix is consumed.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define hk-as-list
+  (fn (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(define
+  hk-eval-list
+  (fn (src) (hk-as-list (hk-eval-expr-source src))))
+
+;; ── Prelude basics ──
+(hk-test "head of literal" (hk-eval-expr-source "head [1, 2, 3]") 1)
+(hk-test
+  "tail of literal"
+  (hk-eval-list "tail [1, 2, 3]")
+  (list 2 3))
+(hk-test "length" (hk-eval-expr-source "length [10, 20, 30, 40]") 4)
+(hk-test "length empty" (hk-eval-expr-source "length []") 0)
+(hk-test
+  "map with section"
+  (hk-eval-list "map (+ 1) [1, 2, 3]")
+  (list 2 3 4))
+(hk-test
+  "filter"
+  (hk-eval-list "filter (\\x -> x > 2) [1, 2, 3, 4, 5]")
+  (list 3 4 5))
+(hk-test
+  "drop"
+  (hk-eval-list "drop 2 [10, 20, 30, 40]")
+  (list 30 40))
+(hk-test "fst" (hk-eval-expr-source "fst (7, 9)") 7)
+(hk-test "snd" (hk-eval-expr-source "snd (7, 9)") 9)
+(hk-test
+  "zipWith"
+  (hk-eval-list "zipWith plus [1, 2, 3] [10, 20, 30]")
+  (list 11 22 33))
+
+;; ── Infinite structures ──
+(hk-test
+  "take from repeat"
+  (hk-eval-list "take 5 (repeat 7)")
+  (list 7 7 7 7 7))
+(hk-test
+  "take 0 from repeat returns empty"
+  (hk-eval-list "take 0 (repeat 7)")
+  (list))
+(hk-test
+  "take from iterate"
+  (hk-eval-list "take 5 (iterate (\\x -> x + 1) 0)")
+  (list 0 1 2 3 4))
+(hk-test
+  "iterate with multiplication"
+  (hk-eval-list "take 4 (iterate (\\x -> x * 2) 1)")
+  (list 1 2 4 8))
+(hk-test
+  "head of repeat"
+  (hk-eval-expr-source "head (repeat 99)")
+  99)
+
+;; ── Fibonacci stream ──
+(hk-test
+  "first 10 Fibonacci numbers"
+  (hk-eval-list "take 10 fibs")
+  (list 0 1 1 2 3 5 8 13 21 34))
+(hk-test
+  "fib at position 8"
+  (hk-eval-expr-source "head (drop 8 fibs)")
+  21)
+
+;; ── Building infinite structures in user code ──
+(hk-test
+  "user-defined infinite ones"
+  (hk-prog-val
+    "ones = 1 : ones\nresult = take 6 ones"
+    "result")
+  (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list "[]"))))))))
+
+(hk-test
+  "user-defined nats"
+  (hk-prog-val
+    "nats = naturalsFrom 1\nnaturalsFrom n = n : naturalsFrom (n + 1)\nresult = take 5 nats"
+    "result")
+  (list ":" 1 (list ":" 2 (list ":" 3 (list ":" 4 (list ":" 5 (list "[]")))))))
+
+;; ── Range syntax ──
+(hk-test
+  "finite range [1..5]"
+  (hk-eval-list "[1..5]")
+  (list 1 2 3 4 5))
+(hk-test
+  "empty range when from > to"
+  (hk-eval-list "[10..3]")
+  (list))
+(hk-test
+  "stepped range"
+  (hk-eval-list "[1, 3..10]")
+  (list 1 3 5 7 9))
+(hk-test
+  "open range — head"
+  (hk-eval-expr-source "head [1..]")
+  1)
+(hk-test
+  "open range — drop then head"
+  (hk-eval-expr-source "head (drop 99 [1..])")
+  100)
+(hk-test
+  "open range — take 5"
+  (hk-eval-list "take 5 [10..]")
+  (list 10 11 12 13 14))
+
+;; ── Composing Prelude functions ──
+(hk-test
+  "map then filter"
+  (hk-eval-list
+    "filter (\\x -> x > 5) (map (\\x -> x * 2) [1, 2, 3, 4])")
+  (list 6 8))
+
+(hk-test
+  "sum-via-foldless"
+  (hk-prog-val
+    "mySum [] = 0\nmySum (x:xs) = x + mySum xs\nresult = mySum (take 5 (iterate (\\x -> x + 1) 1))"
+    "result")
+  15)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/layout.sx

@@ -0,0 +1,245 @@
+;; Haskell layout-rule tests. hk-tokenizer + hk-layout produce a
+;; virtual-brace-annotated stream; these tests cover the algorithm
+;; from Haskell 98 §10.3 plus the pragmatic let/in single-line rule.
+
+;; Convenience — tokenize, run layout, strip eof, keep :type/:value.
+(define
+  hk-lay
+  (fn
+    (src)
+    (map
+      (fn (tok) {:value (get tok "value") :type (get tok "type")})
+      (filter
+        (fn (tok) (not (= (get tok "type") "eof")))
+        (hk-layout (hk-tokenize src))))))
+
+;; ── 1. Basics ──
+(hk-test
+  "empty input produces empty module { }"
+  (hk-lay "")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "single token → module open+close"
+  (hk-lay "foo")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "foo" :type "varid"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "two top-level decls get vsemi between"
+  (hk-lay "foo = 1\nbar = 2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "foo" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value ";" :type "vsemi"}
+    {:value "bar" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 2. Layout keywords — do / let / where / of ──
+(hk-test
+  "do block with two stmts"
+  (hk-lay "f = do\n  x\n  y")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value ";" :type "vsemi"}
+    {:value "y" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "single-line let ... in"
+  (hk-lay "let x = 1 in x")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "let" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "in" :type "reserved"}
+    {:value "x" :type "varid"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "where block with two bindings"
+  (hk-lay "f = g\n  where\n    g = 1\n    h = 2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "g" :type "varid"}
+    {:value "where" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "g" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value ";" :type "vsemi"}
+    {:value "h" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "case … of with arms"
+  (hk-lay "f x = case x of\n  Just y -> y\n  Nothing -> 0")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "case" :type "reserved"}
+    {:value "x" :type "varid"}
+    {:value "of" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "Just" :type "conid"}
+    {:value "y" :type "varid"}
+    {:value "->" :type "reservedop"}
+    {:value "y" :type "varid"}
+    {:value ";" :type "vsemi"}
+    {:value "Nothing" :type "conid"}
+    {:value "->" :type "reservedop"}
+    {:value 0 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 3. Explicit braces disable layout ──
+(hk-test
+  "explicit braces — no implicit vlbrace/vsemi/vrbrace inside"
+  (hk-lay "do { x ; y }")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "lbrace"}
+    {:value "x" :type "varid"}
+    {:value ";" :type "semi"}
+    {:value "y" :type "varid"}
+    {:value "}" :type "rbrace"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 4. Dedent closes nested blocks ──
+(hk-test
+  "dedent back to module level closes do block"
+  (hk-lay "f = do\n  x\n  y\ng = 2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value ";" :type "vsemi"}
+    {:value "y" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value ";" :type "vsemi"}
+    {:value "g" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "dedent closes inner let, emits vsemi at outer do level"
+  (hk-lay "main = do\n  let x = 1\n  print x")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "main" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "let" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value ";" :type "vsemi"}
+    {:value "print" :type "varid"}
+    {:value "x" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 5. Module header skips outer implicit open ──
+(hk-test
+  "module M where — only where opens a block"
+  (hk-lay "module M where\n  f = 1")
+  (list
+    {:value "module" :type "reserved"}
+    {:value "M" :type "conid"}
+    {:value "where" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 6. Newlines are stripped ──
+(hk-test
+  "newline tokens do not appear in output"
+  (let
+    ((toks (hk-layout (hk-tokenize "foo\nbar"))))
+    (every?
+      (fn (t) (not (= (get t "type") "newline")))
+      toks))
+  true)
+
+;; ── 7. Continuation — deeper indent does NOT emit vsemi ──
+(hk-test
+  "line continuation (deeper indent) just merges"
+  (hk-lay "foo = 1 +\n   2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "foo" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "+" :type "varsym"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 8. Stack closing at EOF ──
+(hk-test
+  "EOF inside nested do closes all implicit blocks"
+  (let
+    ((toks (hk-lay "main = do\n  do\n    x")))
+    (let
+      ((n (len toks)))
+      (list
+        (get (nth toks (- n 1)) "type")
+        (get (nth toks (- n 2)) "type")
+        (get (nth toks (- n 3)) "type"))))
+  (list "vrbrace" "vrbrace" "vrbrace"))
+
+;; ── 9. Qualified-newline: x at deeper col than stack top does nothing ──
+(hk-test
+  "mixed where + do"
+  (hk-lay "f = do\n    x\n  where\n    x = 1")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value "where" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/match.sx

@@ -0,0 +1,256 @@
+;; Pattern-matcher tests. The matcher takes (pat val env) and returns
+;; an extended env dict on success, or `nil` on failure. Constructor
+;; values are tagged lists (con-name first); tuples use the "Tuple"
+;; tag; lists use chained `:` cons with `[]` nil.
+
+;; ── Atomic patterns ──
+(hk-test
+  "wildcard always matches"
+  (hk-match (list :p-wild) 42 (dict))
+  (dict))
+
+(hk-test
+  "var binds value"
+  (hk-match (list :p-var "x") 42 (dict))
+  {:x 42})
+
+(hk-test
+  "var preserves prior env"
+  (hk-match (list :p-var "y") 7 {:x 1})
+  {:x 1 :y 7})
+
+(hk-test
+  "int literal matches equal"
+  (hk-match (list :p-int 5) 5 (dict))
+  (dict))
+
+(hk-test
+  "int literal fails on mismatch"
+  (hk-match (list :p-int 5) 6 (dict))
+  nil)
+
+(hk-test
+  "negative int literal matches"
+  (hk-match (list :p-int -3) -3 (dict))
+  (dict))
+
+(hk-test
+  "string literal matches"
+  (hk-match (list :p-string "hi") "hi" (dict))
+  (dict))
+
+(hk-test
+  "string literal fails"
+  (hk-match (list :p-string "hi") "bye" (dict))
+  nil)
+
+(hk-test
+  "char literal matches"
+  (hk-match (list :p-char "a") "a" (dict))
+  (dict))
+
+;; ── Constructor patterns ──
+(hk-test
+  "0-arity con matches"
+  (hk-match
+    (list :p-con "Nothing" (list))
+    (hk-mk-con "Nothing" (list))
+    (dict))
+  (dict))
+
+(hk-test
+  "1-arity con matches and binds"
+  (hk-match
+    (list :p-con "Just" (list (list :p-var "y")))
+    (hk-mk-con "Just" (list 9))
+    (dict))
+  {:y 9})
+
+(hk-test
+  "con name mismatch fails"
+  (hk-match
+    (list :p-con "Just" (list (list :p-var "y")))
+    (hk-mk-con "Nothing" (list))
+    (dict))
+  nil)
+
+(hk-test
+  "con arity mismatch fails"
+  (hk-match
+    (list :p-con "Pair" (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-con "Pair" (list 1))
+    (dict))
+  nil)
+
+(hk-test
+  "nested con: Just (Just x)"
+  (hk-match
+    (list
+      :p-con
+      "Just"
+      (list
+        (list
+          :p-con
+          "Just"
+          (list (list :p-var "x")))))
+    (hk-mk-con "Just" (list (hk-mk-con "Just" (list 42))))
+    (dict))
+  {:x 42})
+
+;; ── Tuple patterns ──
+(hk-test
+  "2-tuple matches and binds"
+  (hk-match
+    (list
+      :p-tuple
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-tuple (list 10 20))
+    (dict))
+  {:a 10 :b 20})
+
+(hk-test
+  "tuple arity mismatch fails"
+  (hk-match
+    (list
+      :p-tuple
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-tuple (list 10 20 30))
+    (dict))
+  nil)
+
+;; ── List patterns ──
+(hk-test
+  "[] pattern matches empty list"
+  (hk-match (list :p-list (list)) (hk-mk-nil) (dict))
+  (dict))
+
+(hk-test
+  "[] pattern fails on non-empty"
+  (hk-match (list :p-list (list)) (hk-mk-list (list 1)) (dict))
+  nil)
+
+(hk-test
+  "[a] pattern matches singleton"
+  (hk-match
+    (list :p-list (list (list :p-var "a")))
+    (hk-mk-list (list 7))
+    (dict))
+  {:a 7})
+
+(hk-test
+  "[a, b] pattern matches pair-list and binds"
+  (hk-match
+    (list
+      :p-list
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-list (list 1 2))
+    (dict))
+  {:a 1 :b 2})
+
+(hk-test
+  "[a, b] fails on too-long list"
+  (hk-match
+    (list
+      :p-list
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-list (list 1 2 3))
+    (dict))
+  nil)
+
+;; Cons-style infix pattern (which the parser produces as :p-con ":")
+(hk-test
+  "cons (h:t) on non-empty list"
+  (hk-match
+    (list
+      :p-con
+      ":"
+      (list (list :p-var "h") (list :p-var "t")))
+    (hk-mk-list (list 1 2 3))
+    (dict))
+  {:h 1 :t (list ":" 2 (list ":" 3 (list "[]")))})
+
+(hk-test
+  "cons fails on empty list"
+  (hk-match
+    (list
+      :p-con
+      ":"
+      (list (list :p-var "h") (list :p-var "t")))
+    (hk-mk-nil)
+    (dict))
+  nil)
+
+;; ── as patterns ──
+(hk-test
+  "as binds whole + sub-pattern"
+  (hk-match
+    (list
+      :p-as
+      "all"
+      (list :p-con "Just" (list (list :p-var "x"))))
+    (hk-mk-con "Just" (list 99))
+    (dict))
+  {:all (list "Just" 99) :x 99})
+
+(hk-test
+  "as on wildcard binds whole"
+  (hk-match
+    (list :p-as "v" (list :p-wild))
+    "anything"
+    (dict))
+  {:v "anything"})
+
+(hk-test
+  "as fails when sub-pattern fails"
+  (hk-match
+    (list
+      :p-as
+      "n"
+      (list :p-con "Just" (list (list :p-var "x"))))
+    (hk-mk-con "Nothing" (list))
+    (dict))
+  nil)
+
+;; ── lazy ~ pattern (eager equivalent for now) ──
+(hk-test
+  "lazy pattern eager-matches its inner"
+  (hk-match
+    (list :p-lazy (list :p-var "y"))
+    42
+    (dict))
+  {:y 42})
+
+;; ── Source-driven: parse a real Haskell pattern, match a value ──
+(hk-test
+  "parsed pattern: Just x against Just 5"
+  (hk-match
+    (hk-parse-pat-source "Just x")
+    (hk-mk-con "Just" (list 5))
+    (dict))
+  {:x 5})
+
+(hk-test
+  "parsed pattern: x : xs against [10, 20, 30]"
+  (hk-match
+    (hk-parse-pat-source "x : xs")
+    (hk-mk-list (list 10 20 30))
+    (dict))
+  {:x 10 :xs (list ":" 20 (list ":" 30 (list "[]")))})
+
+(hk-test
+  "parsed pattern: (a, b) against (1, 2)"
+  (hk-match
+    (hk-parse-pat-source "(a, b)")
+    (hk-mk-tuple (list 1 2))
+    (dict))
+  {:a 1 :b 2})
+
+(hk-test
+  "parsed pattern: n@(Just x) against Just 7"
+  (hk-match
+    (hk-parse-pat-source "n@(Just x)")
+    (hk-mk-con "Just" (list 7))
+    (dict))
+  {:n (list "Just" 7) :x 7})
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parse.sx

@@ -3,60 +3,8 @@
 ;; Lightweight runner: each test checks actual vs expected with
 ;; structural (deep) equality and accumulates pass/fail counters.
 ;; Final value of this file is a summary dict with :pass :fail :fails.
-
+;; The hk-test / hk-deep=? helpers live in lib/haskell/testlib.sx
-(define
+;; and are preloaded by lib/haskell/test.sh.
-  hk-deep=?
-  (fn
-    (a b)
-    (cond
-      ((= a b) true)
-      ((and (dict? a) (dict? b))
-        (let
-          ((ak (keys a)) (bk (keys b)))
-          (if
-            (not (= (len ak) (len bk)))
-            false
-            (every?
-              (fn
-                (k)
-                (and (has-key? b k) (hk-deep=? (get a k) (get b k))))
-              ak))))
-      ((and (list? a) (list? b))
-        (if
-          (not (= (len a) (len b)))
-          false
-          (let
-            ((i 0) (ok true))
-            (define
-              hk-de-loop
-              (fn
-                ()
-                (when
-                  (and ok (< i (len a)))
-                  (do
-                    (when
-                      (not (hk-deep=? (nth a i) (nth b i)))
-                      (set! ok false))
-                    (set! i (+ i 1))
-                    (hk-de-loop)))))
-            (hk-de-loop)
-            ok)))
-      (:else false))))
-
-(define hk-test-pass 0)
-(define hk-test-fail 0)
-(define hk-test-fails (list))
-
-(define
-  hk-test
-  (fn
-    (name actual expected)
-    (if
-      (hk-deep=? actual expected)
-      (set! hk-test-pass (+ hk-test-pass 1))
-      (do
-        (set! hk-test-fail (+ hk-test-fail 1))
-        (append! hk-test-fails {:actual actual :expected expected :name name})))))
 
 ;; Convenience: tokenize and drop newline + eof tokens so tests focus
 ;; on meaningful content. Returns list of {:type :value} pairs.

lib/haskell/tests/parser-case-do.sx

@@ -0,0 +1,278 @@
+;; case-of and do-notation parser tests.
+;; Covers the minimal patterns needed to make these meaningful: var,
+;; wildcard, literal, constructor (with and without args), tuple, list.
+
+;; ── Patterns (in case arms) ──
+(hk-test
+  "wildcard pat"
+  (hk-parse "case x of _ -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "var pat"
+  (hk-parse "case x of y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-var "y") (list :var "y")))))
+
+(hk-test
+  "0-arity constructor pat"
+  (hk-parse "case x of\n  Nothing -> 0\n  Just y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0))
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :var "y")))))
+
+(hk-test
+  "int literal pat"
+  (hk-parse "case n of\n  0 -> 1\n  _ -> n")
+  (list
+    :case
+    (list :var "n")
+    (list
+      (list :alt (list :p-int 0) (list :int 1))
+      (list :alt (list :p-wild) (list :var "n")))))
+
+(hk-test
+  "string literal pat"
+  (hk-parse "case s of\n  \"hi\" -> 1\n  _ -> 0")
+  (list
+    :case
+    (list :var "s")
+    (list
+      (list :alt (list :p-string "hi") (list :int 1))
+      (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "tuple pat"
+  (hk-parse "case p of (a, b) -> a")
+  (list
+    :case
+    (list :var "p")
+    (list
+      (list
+        :alt
+        (list
+          :p-tuple
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+(hk-test
+  "list pat"
+  (hk-parse "case xs of\n  [] -> 0\n  [a] -> a")
+  (list
+    :case
+    (list :var "xs")
+    (list
+      (list :alt (list :p-list (list)) (list :int 0))
+      (list
+        :alt
+        (list :p-list (list (list :p-var "a")))
+        (list :var "a")))))
+
+(hk-test
+  "nested constructor pat"
+  (hk-parse "case x of\n  Just (a, b) -> a\n  _ -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          "Just"
+          (list
+            (list
+              :p-tuple
+              (list (list :p-var "a") (list :p-var "b")))))
+        (list :var "a"))
+      (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "constructor with multiple var args"
+  (hk-parse "case t of Pair a b -> a")
+  (list
+    :case
+    (list :var "t")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          "Pair"
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+;; ── case-of shapes ──
+(hk-test
+  "case with explicit braces"
+  (hk-parse "case x of { Just y -> y ; Nothing -> 0 }")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :var "y"))
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
+
+(hk-test
+  "case scrutinee is a full expression"
+  (hk-parse "case f x + 1 of\n  y -> y")
+  (list
+    :case
+    (list
+      :op
+      "+"
+      (list :app (list :var "f") (list :var "x"))
+      (list :int 1))
+    (list (list :alt (list :p-var "y") (list :var "y")))))
+
+(hk-test
+  "case arm body is full expression"
+  (hk-parse "case x of\n  Just y -> y + 1")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :op "+" (list :var "y") (list :int 1))))))
+
+;; ── do blocks ──
+(hk-test
+  "do with two expressions"
+  (hk-parse "do\n  putStrLn \"hi\"\n  return 0")
+  (list
+    :do
+    (list
+      (list
+        :do-expr
+        (list :app (list :var "putStrLn") (list :string "hi")))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :int 0))))))
+
+(hk-test
+  "do with bind"
+  (hk-parse "do\n  x <- getLine\n  putStrLn x")
+  (list
+    :do
+    (list
+      (list :do-bind (list :p-var "x") (list :var "getLine"))
+      (list
+        :do-expr
+        (list :app (list :var "putStrLn") (list :var "x"))))))
+
+(hk-test
+  "do with let"
+  (hk-parse "do\n  let y = 5\n  print y")
+  (list
+    :do
+    (list
+      (list
+        :do-let
+        (list (list :bind (list :p-var "y") (list :int 5))))
+      (list
+        :do-expr
+        (list :app (list :var "print") (list :var "y"))))))
+
+(hk-test
+  "do with multiple let bindings"
+  (hk-parse "do\n  let x = 1\n      y = 2\n  print (x + y)")
+  (list
+    :do
+    (list
+      (list
+        :do-let
+        (list
+          (list :bind (list :p-var "x") (list :int 1))
+          (list :bind (list :p-var "y") (list :int 2))))
+      (list
+        :do-expr
+        (list
+          :app
+          (list :var "print")
+          (list :op "+" (list :var "x") (list :var "y")))))))
+
+(hk-test
+  "do with bind using constructor pat"
+  (hk-parse "do\n  Just x <- getMaybe\n  return x")
+  (list
+    :do
+    (list
+      (list
+        :do-bind
+        (list :p-con "Just" (list (list :p-var "x")))
+        (list :var "getMaybe"))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :var "x"))))))
+
+(hk-test
+  "do with explicit braces"
+  (hk-parse "do { x <- a ; y <- b ; return (x + y) }")
+  (list
+    :do
+    (list
+      (list :do-bind (list :p-var "x") (list :var "a"))
+      (list :do-bind (list :p-var "y") (list :var "b"))
+      (list
+        :do-expr
+        (list
+          :app
+          (list :var "return")
+          (list :op "+" (list :var "x") (list :var "y")))))))
+
+;; ── Mixing case/do inside expressions ──
+(hk-test
+  "case inside let"
+  (hk-parse "let f = \\x -> case x of\n                 Just y -> y\n                 _ -> 0\nin f 5")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list :p-var "f")
+        (list
+          :lambda
+          (list (list :p-var "x"))
+          (list
+            :case
+            (list :var "x")
+            (list
+              (list
+                :alt
+                (list :p-con "Just" (list (list :p-var "y")))
+                (list :var "y"))
+              (list :alt (list :p-wild) (list :int 0)))))))
+    (list :app (list :var "f") (list :int 5))))
+
+(hk-test
+  "lambda containing do"
+  (hk-parse "\\x -> do\n  y <- x\n  return y")
+  (list
+    :lambda
+    (list (list :p-var "x"))
+    (list
+      :do
+      (list
+        (list :do-bind (list :p-var "y") (list :var "x"))
+        (list
+          :do-expr
+          (list :app (list :var "return") (list :var "y")))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-decls.sx

@@ -0,0 +1,273 @@
+;; Top-level declarations: function clauses, type signatures, data,
+;; type, newtype, fixity. Driven by hk-parse-top which produces
+;; a (:program DECLS) node.
+
+(define
+  hk-prog
+  (fn
+    (&rest decls)
+    (list :program decls)))
+
+;; ── Function clauses & pattern bindings ──
+(hk-test
+  "simple fun-clause"
+  (hk-parse-top "f x = x + 1")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list :op "+" (list :var "x") (list :int 1)))))
+
+(hk-test
+  "nullary decl"
+  (hk-parse-top "answer = 42")
+  (hk-prog
+    (list :fun-clause "answer" (list) (list :int 42))))
+
+(hk-test
+  "multi-clause fn (separate defs for each pattern)"
+  (hk-parse-top "fact 0 = 1\nfact n = n")
+  (hk-prog
+    (list :fun-clause "fact" (list (list :p-int 0)) (list :int 1))
+    (list
+      :fun-clause
+      "fact"
+      (list (list :p-var "n"))
+      (list :var "n"))))
+
+(hk-test
+  "constructor pattern in fn args"
+  (hk-parse-top "fromJust (Just x) = x")
+  (hk-prog
+    (list
+      :fun-clause
+      "fromJust"
+      (list (list :p-con "Just" (list (list :p-var "x"))))
+      (list :var "x"))))
+
+(hk-test
+  "pattern binding at top level"
+  (hk-parse-top "(a, b) = pair")
+  (hk-prog
+    (list
+      :pat-bind
+      (list
+        :p-tuple
+        (list (list :p-var "a") (list :p-var "b")))
+      (list :var "pair"))))
+
+;; ── Type signatures ──
+(hk-test
+  "single-name sig"
+  (hk-parse-top "f :: Int -> Int")
+  (hk-prog
+    (list
+      :type-sig
+      (list "f")
+      (list :t-fun (list :t-con "Int") (list :t-con "Int")))))
+
+(hk-test
+  "multi-name sig"
+  (hk-parse-top "f, g, h :: Int -> Bool")
+  (hk-prog
+    (list
+      :type-sig
+      (list "f" "g" "h")
+      (list :t-fun (list :t-con "Int") (list :t-con "Bool")))))
+
+(hk-test
+  "sig with type application"
+  (hk-parse-top "f :: Maybe a -> a")
+  (hk-prog
+    (list
+      :type-sig
+      (list "f")
+      (list
+        :t-fun
+        (list :t-app (list :t-con "Maybe") (list :t-var "a"))
+        (list :t-var "a")))))
+
+(hk-test
+  "sig with list type"
+  (hk-parse-top "len :: [a] -> Int")
+  (hk-prog
+    (list
+      :type-sig
+      (list "len")
+      (list
+        :t-fun
+        (list :t-list (list :t-var "a"))
+        (list :t-con "Int")))))
+
+(hk-test
+  "sig with tuple and right-assoc ->"
+  (hk-parse-top "pair :: a -> b -> (a, b)")
+  (hk-prog
+    (list
+      :type-sig
+      (list "pair")
+      (list
+        :t-fun
+        (list :t-var "a")
+        (list
+          :t-fun
+          (list :t-var "b")
+          (list
+            :t-tuple
+            (list (list :t-var "a") (list :t-var "b"))))))))
+
+(hk-test
+  "sig + implementation together"
+  (hk-parse-top "id :: a -> a\nid x = x")
+  (hk-prog
+    (list
+      :type-sig
+      (list "id")
+      (list :t-fun (list :t-var "a") (list :t-var "a")))
+    (list
+      :fun-clause
+      "id"
+      (list (list :p-var "x"))
+      (list :var "x"))))
+
+;; ── data declarations ──
+(hk-test
+  "data Maybe"
+  (hk-parse-top "data Maybe a = Nothing | Just a")
+  (hk-prog
+    (list
+      :data
+      "Maybe"
+      (list "a")
+      (list
+        (list :con-def "Nothing" (list))
+        (list :con-def "Just" (list (list :t-var "a")))))))
+
+(hk-test
+  "data Either"
+  (hk-parse-top "data Either a b = Left a | Right b")
+  (hk-prog
+    (list
+      :data
+      "Either"
+      (list "a" "b")
+      (list
+        (list :con-def "Left" (list (list :t-var "a")))
+        (list :con-def "Right" (list (list :t-var "b")))))))
+
+(hk-test
+  "data with no type parameters"
+  (hk-parse-top "data Bool = True | False")
+  (hk-prog
+    (list
+      :data
+      "Bool"
+      (list)
+      (list
+        (list :con-def "True" (list))
+        (list :con-def "False" (list))))))
+
+(hk-test
+  "recursive data type"
+  (hk-parse-top "data Tree a = Leaf | Node (Tree a) a (Tree a)")
+  (hk-prog
+    (list
+      :data
+      "Tree"
+      (list "a")
+      (list
+        (list :con-def "Leaf" (list))
+        (list
+          :con-def
+          "Node"
+          (list
+            (list :t-app (list :t-con "Tree") (list :t-var "a"))
+            (list :t-var "a")
+            (list :t-app (list :t-con "Tree") (list :t-var "a"))))))))
+
+;; ── type synonyms ──
+(hk-test
+  "simple type synonym"
+  (hk-parse-top "type Name = String")
+  (hk-prog
+    (list :type-syn "Name" (list) (list :t-con "String"))))
+
+(hk-test
+  "parameterised type synonym"
+  (hk-parse-top "type Pair a = (a, a)")
+  (hk-prog
+    (list
+      :type-syn
+      "Pair"
+      (list "a")
+      (list
+        :t-tuple
+        (list (list :t-var "a") (list :t-var "a"))))))
+
+;; ── newtype ──
+(hk-test
+  "newtype"
+  (hk-parse-top "newtype Age = Age Int")
+  (hk-prog (list :newtype "Age" (list) "Age" (list :t-con "Int"))))
+
+(hk-test
+  "parameterised newtype"
+  (hk-parse-top "newtype Wrap a = Wrap a")
+  (hk-prog
+    (list :newtype "Wrap" (list "a") "Wrap" (list :t-var "a"))))
+
+;; ── fixity declarations ──
+(hk-test
+  "infixl with precedence"
+  (hk-parse-top "infixl 5 +:, -:")
+  (hk-prog (list :fixity "l" 5 (list "+:" "-:"))))
+
+(hk-test
+  "infixr"
+  (hk-parse-top "infixr 9 .")
+  (hk-prog (list :fixity "r" 9 (list "."))))
+
+(hk-test
+  "infix (non-assoc) default prec"
+  (hk-parse-top "infix ==")
+  (hk-prog (list :fixity "n" 9 (list "=="))))
+
+(hk-test
+  "fixity with backtick operator name"
+  (hk-parse-top "infixl 7 `div`")
+  (hk-prog (list :fixity "l" 7 (list "div"))))
+
+;; ── Several decls combined ──
+(hk-test
+  "mixed: data + sig + fn + type"
+  (hk-parse-top "data Maybe a = Nothing | Just a\ntype Entry = Maybe Int\nf :: Entry -> Int\nf (Just x) = x\nf Nothing = 0")
+  (hk-prog
+    (list
+      :data
+      "Maybe"
+      (list "a")
+      (list
+        (list :con-def "Nothing" (list))
+        (list :con-def "Just" (list (list :t-var "a")))))
+    (list
+      :type-syn
+      "Entry"
+      (list)
+      (list :t-app (list :t-con "Maybe") (list :t-con "Int")))
+    (list
+      :type-sig
+      (list "f")
+      (list :t-fun (list :t-con "Entry") (list :t-con "Int")))
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-con "Just" (list (list :p-var "x"))))
+      (list :var "x"))
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-con "Nothing" (list)))
+      (list :int 0))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-expr.sx

@@ -0,0 +1,258 @@
+;; Haskell expression parser tests.
+;; hk-parse tokenises, runs layout, then parses. Output is an AST
+;; whose head is a keyword tag (evaluates to its string name).
+
+;; ── 1. Literals ──
+(hk-test "integer" (hk-parse "42") (list :int 42))
+(hk-test "float" (hk-parse "3.14") (list :float 3.14))
+(hk-test "string" (hk-parse "\"hi\"") (list :string "hi"))
+(hk-test "char" (hk-parse "'a'") (list :char "a"))
+
+;; ── 2. Variables and constructors ──
+(hk-test "varid" (hk-parse "foo") (list :var "foo"))
+(hk-test "conid" (hk-parse "Nothing") (list :con "Nothing"))
+(hk-test "qvarid" (hk-parse "Data.Map.lookup") (list :var "Data.Map.lookup"))
+(hk-test "qconid" (hk-parse "Data.Map") (list :con "Data.Map"))
+
+;; ── 3. Parens / unit / tuple ──
+(hk-test "parens strip" (hk-parse "(42)") (list :int 42))
+(hk-test "unit" (hk-parse "()") (list :con "()"))
+(hk-test
+  "2-tuple"
+  (hk-parse "(1, 2)")
+  (list :tuple (list (list :int 1) (list :int 2))))
+(hk-test
+  "3-tuple"
+  (hk-parse "(x, y, z)")
+  (list
+    :tuple
+    (list (list :var "x") (list :var "y") (list :var "z"))))
+
+;; ── 4. Lists ──
+(hk-test "empty list" (hk-parse "[]") (list :list (list)))
+(hk-test
+  "singleton list"
+  (hk-parse "[1]")
+  (list :list (list (list :int 1))))
+(hk-test
+  "list of ints"
+  (hk-parse "[1, 2, 3]")
+  (list
+    :list
+    (list (list :int 1) (list :int 2) (list :int 3))))
+(hk-test
+  "range"
+  (hk-parse "[1..10]")
+  (list :range (list :int 1) (list :int 10)))
+(hk-test
+  "range with step"
+  (hk-parse "[1, 3..10]")
+  (list
+    :range-step
+    (list :int 1)
+    (list :int 3)
+    (list :int 10)))
+
+;; ── 5. Application ──
+(hk-test
+  "one-arg app"
+  (hk-parse "f x")
+  (list :app (list :var "f") (list :var "x")))
+(hk-test
+  "multi-arg app is left-assoc"
+  (hk-parse "f x y z")
+  (list
+    :app
+    (list
+      :app
+      (list :app (list :var "f") (list :var "x"))
+      (list :var "y"))
+    (list :var "z")))
+(hk-test
+  "app with con"
+  (hk-parse "Just 5")
+  (list :app (list :con "Just") (list :int 5)))
+
+;; ── 6. Infix operators ──
+(hk-test
+  "simple +"
+  (hk-parse "1 + 2")
+  (list :op "+" (list :int 1) (list :int 2)))
+(hk-test
+  "precedence: * binds tighter than +"
+  (hk-parse "1 + 2 * 3")
+  (list
+    :op
+    "+"
+    (list :int 1)
+    (list :op "*" (list :int 2) (list :int 3))))
+(hk-test
+  "- is left-assoc"
+  (hk-parse "10 - 3 - 2")
+  (list
+    :op
+    "-"
+    (list :op "-" (list :int 10) (list :int 3))
+    (list :int 2)))
+(hk-test
+  ": is right-assoc"
+  (hk-parse "a : b : c")
+  (list
+    :op
+    ":"
+    (list :var "a")
+    (list :op ":" (list :var "b") (list :var "c"))))
+(hk-test
+  "app binds tighter than op"
+  (hk-parse "f x + g y")
+  (list
+    :op
+    "+"
+    (list :app (list :var "f") (list :var "x"))
+    (list :app (list :var "g") (list :var "y"))))
+(hk-test
+  "$ is lowest precedence, right-assoc"
+  (hk-parse "f $ g x")
+  (list
+    :op
+    "$"
+    (list :var "f")
+    (list :app (list :var "g") (list :var "x"))))
+
+;; ── 7. Backticks (varid-as-operator) ──
+(hk-test
+  "backtick operator"
+  (hk-parse "x `mod` 3")
+  (list :op "mod" (list :var "x") (list :int 3)))
+
+;; ── 8. Unary negation ──
+(hk-test
+  "unary -"
+  (hk-parse "- 5")
+  (list :neg (list :int 5)))
+(hk-test
+  "unary - on application"
+  (hk-parse "- f x")
+  (list :neg (list :app (list :var "f") (list :var "x"))))
+(hk-test
+  "- n + m → (- n) + m"
+  (hk-parse "- 1 + 2")
+  (list
+    :op
+    "+"
+    (list :neg (list :int 1))
+    (list :int 2)))
+
+;; ── 9. Lambda ──
+(hk-test
+  "lambda single param"
+  (hk-parse "\\x -> x")
+  (list :lambda (list (list :p-var "x")) (list :var "x")))
+(hk-test
+  "lambda multi-param"
+  (hk-parse "\\x y -> x + y")
+  (list
+    :lambda
+    (list (list :p-var "x") (list :p-var "y"))
+    (list :op "+" (list :var "x") (list :var "y"))))
+(hk-test
+  "lambda body is full expression"
+  (hk-parse "\\f -> f 1 + f 2")
+  (list
+    :lambda
+    (list (list :p-var "f"))
+    (list
+      :op
+      "+"
+      (list :app (list :var "f") (list :int 1))
+      (list :app (list :var "f") (list :int 2)))))
+
+;; ── 10. if-then-else ──
+(hk-test
+  "if basic"
+  (hk-parse "if x then 1 else 2")
+  (list :if (list :var "x") (list :int 1) (list :int 2)))
+(hk-test
+  "if with infix cond"
+  (hk-parse "if x == 0 then y else z")
+  (list
+    :if
+    (list :op "==" (list :var "x") (list :int 0))
+    (list :var "y")
+    (list :var "z")))
+
+;; ── 11. let-in ──
+(hk-test
+  "let single binding"
+  (hk-parse "let x = 1 in x")
+  (list
+    :let
+    (list (list :bind (list :p-var "x") (list :int 1)))
+    (list :var "x")))
+(hk-test
+  "let two bindings (multi-line)"
+  (hk-parse "let x = 1\n    y = 2\nin x + y")
+  (list
+    :let
+    (list
+      (list :bind (list :p-var "x") (list :int 1))
+      (list :bind (list :p-var "y") (list :int 2)))
+    (list :op "+" (list :var "x") (list :var "y"))))
+(hk-test
+  "let with explicit braces"
+  (hk-parse "let { x = 1 ; y = 2 } in x + y")
+  (list
+    :let
+    (list
+      (list :bind (list :p-var "x") (list :int 1))
+      (list :bind (list :p-var "y") (list :int 2)))
+    (list :op "+" (list :var "x") (list :var "y"))))
+
+;; ── 12. Mixed / nesting ──
+(hk-test
+  "nested application"
+  (hk-parse "f (g x) y")
+  (list
+    :app
+    (list
+      :app
+      (list :var "f")
+      (list :app (list :var "g") (list :var "x")))
+    (list :var "y")))
+(hk-test
+  "lambda applied"
+  (hk-parse "(\\x -> x + 1) 5")
+  (list
+    :app
+    (list
+      :lambda
+      (list (list :p-var "x"))
+      (list :op "+" (list :var "x") (list :int 1)))
+    (list :int 5)))
+(hk-test
+  "lambda + if"
+  (hk-parse "\\n -> if n == 0 then 1 else n")
+  (list
+    :lambda
+    (list (list :p-var "n"))
+    (list
+      :if
+      (list :op "==" (list :var "n") (list :int 0))
+      (list :int 1)
+      (list :var "n"))))
+
+;; ── 13. Precedence corners ──
+(hk-test
+  ". is right-assoc (prec 9)"
+  (hk-parse "f . g . h")
+  (list
+    :op
+    "."
+    (list :var "f")
+    (list :op "." (list :var "g") (list :var "h"))))
+(hk-test
+  "== is non-associative (single use)"
+  (hk-parse "x == y")
+  (list :op "==" (list :var "x") (list :var "y")))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-guards-where.sx

@@ -0,0 +1,261 @@
+;; Guards and where-clauses — on fun-clauses, case alts, and
+;; let-bindings (which now also accept funclause-style LHS like
+;; `let f x = e` or `let f x | g = e | g = e`).
+
+(define
+  hk-prog
+  (fn (&rest decls) (list :program decls)))
+
+;; ── Guarded fun-clauses ──
+(hk-test
+  "simple guards (two branches)"
+  (hk-parse-top "abs x | x < 0 = - x\n      | otherwise = x")
+  (hk-prog
+    (list
+      :fun-clause
+      "abs"
+      (list (list :p-var "x"))
+      (list
+        :guarded
+        (list
+          (list
+            :guard
+            (list :op "<" (list :var "x") (list :int 0))
+            (list :neg (list :var "x")))
+          (list :guard (list :var "otherwise") (list :var "x")))))))
+
+(hk-test
+  "three-way guard"
+  (hk-parse-top "sign n | n > 0 = 1\n       | n < 0 = -1\n       | otherwise = 0")
+  (hk-prog
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-var "n"))
+      (list
+        :guarded
+        (list
+          (list
+            :guard
+            (list :op ">" (list :var "n") (list :int 0))
+            (list :int 1))
+          (list
+            :guard
+            (list :op "<" (list :var "n") (list :int 0))
+            (list :neg (list :int 1)))
+          (list
+            :guard
+            (list :var "otherwise")
+            (list :int 0)))))))
+
+(hk-test
+  "mixed: one eq clause plus one guarded clause"
+  (hk-parse-top "sign 0 = 0\nsign n | n > 0 = 1\n       | otherwise = -1")
+  (hk-prog
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-int 0))
+      (list :int 0))
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-var "n"))
+      (list
+        :guarded
+        (list
+          (list
+            :guard
+            (list :op ">" (list :var "n") (list :int 0))
+            (list :int 1))
+          (list
+            :guard
+            (list :var "otherwise")
+            (list :neg (list :int 1))))))))
+
+;; ── where on fun-clauses ──
+(hk-test
+  "where with one binding"
+  (hk-parse-top "f x = y + y\n  where y = x + 1")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list :op "+" (list :var "y") (list :var "y"))
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1))))))))
+
+(hk-test
+  "where with multiple bindings"
+  (hk-parse-top "f x = y * z\n  where y = x + 1\n        z = x - 1")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list :op "*" (list :var "y") (list :var "z"))
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1)))
+          (list
+            :fun-clause
+            "z"
+            (list)
+            (list :op "-" (list :var "x") (list :int 1))))))))
+
+(hk-test
+  "guards + where"
+  (hk-parse-top "f x | x > 0 = y\n    | otherwise = 0\n  where y = 99")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list
+          :guarded
+          (list
+            (list
+              :guard
+              (list :op ">" (list :var "x") (list :int 0))
+              (list :var "y"))
+            (list
+              :guard
+              (list :var "otherwise")
+              (list :int 0))))
+        (list
+          (list :fun-clause "y" (list) (list :int 99)))))))
+
+;; ── Guards in case alts ──
+(hk-test
+  "case alt with guards"
+  (hk-parse "case x of\n  Just y | y > 0 -> y\n         | otherwise -> 0\n  Nothing -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list
+          :guarded
+          (list
+            (list
+              :guard
+              (list :op ">" (list :var "y") (list :int 0))
+              (list :var "y"))
+            (list
+              :guard
+              (list :var "otherwise")
+              (list :int 0)))))
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
+
+(hk-test
+  "case alt with where"
+  (hk-parse "case x of\n  Just y -> y + z where z = 5\n  Nothing -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list
+          :where
+          (list :op "+" (list :var "y") (list :var "z"))
+          (list
+            (list :fun-clause "z" (list) (list :int 5)))))
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
+
+;; ── let-bindings: funclause form, guards, where ──
+(hk-test
+  "let with funclause shorthand"
+  (hk-parse "let f x = x + 1 in f 5")
+  (list
+    :let
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list :op "+" (list :var "x") (list :int 1))))
+    (list :app (list :var "f") (list :int 5))))
+
+(hk-test
+  "let with guards"
+  (hk-parse "let f x | x > 0 = x\n        | otherwise = 0\nin f 3")
+  (list
+    :let
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list
+          :guarded
+          (list
+            (list
+              :guard
+              (list :op ">" (list :var "x") (list :int 0))
+              (list :var "x"))
+            (list
+              :guard
+              (list :var "otherwise")
+              (list :int 0))))))
+    (list :app (list :var "f") (list :int 3))))
+
+(hk-test
+  "let funclause + where"
+  (hk-parse "let f x = y where y = x + 1\nin f 7")
+  (list
+    :let
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list
+          :where
+          (list :var "y")
+          (list
+            (list
+              :fun-clause
+              "y"
+              (list)
+              (list :op "+" (list :var "x") (list :int 1)))))))
+    (list :app (list :var "f") (list :int 7))))
+
+;; ── Nested: where inside where (via recursive hk-parse-decl) ──
+(hk-test
+  "where block can contain a type signature"
+  (hk-parse-top "f x = y\n  where y :: Int\n        y = x")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list :var "y")
+        (list
+          (list :type-sig (list "y") (list :t-con "Int"))
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :var "x")))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-module.sx

@@ -0,0 +1,202 @@
+;; Module header + imports. The parser switches from (:program DECLS)
+;; to (:module NAME EXPORTS IMPORTS DECLS) as soon as a module header
+;; or any `import` decl appears.
+
+;; ── Module header ──
+(hk-test
+  "simple module, no exports"
+  (hk-parse-top "module M where\n  f = 1")
+  (list
+    :module
+    "M"
+    nil
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module with dotted name"
+  (hk-parse-top "module Data.Map where\nf = 1")
+  (list
+    :module
+    "Data.Map"
+    nil
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module with empty export list"
+  (hk-parse-top "module M () where\nf = 1")
+  (list
+    :module
+    "M"
+    (list)
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module with exports (var, tycon-all, tycon-with)"
+  (hk-parse-top "module M (f, g, Maybe(..), List(Cons, Nil)) where\nf = 1\ng = 2")
+  (list
+    :module
+    "M"
+    (list
+      (list :ent-var "f")
+      (list :ent-var "g")
+      (list :ent-all "Maybe")
+      (list :ent-with "List" (list "Cons" "Nil")))
+    (list)
+    (list
+      (list :fun-clause "f" (list) (list :int 1))
+      (list :fun-clause "g" (list) (list :int 2)))))
+
+(hk-test
+  "module export list including another module"
+  (hk-parse-top "module M (module Foo, f) where\nf = 1")
+  (list
+    :module
+    "M"
+    (list (list :ent-module "Foo") (list :ent-var "f"))
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module export with operator"
+  (hk-parse-top "module M ((+:), f) where\nf = 1")
+  (list
+    :module
+    "M"
+    (list (list :ent-var "+:") (list :ent-var "f"))
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "empty module body"
+  (hk-parse-top "module M where")
+  (list :module "M" nil (list) (list)))
+
+;; ── Imports ──
+(hk-test
+  "plain import"
+  (hk-parse-top "import Foo")
+  (list
+    :module
+    nil
+    nil
+    (list (list :import false "Foo" nil nil))
+    (list)))
+
+(hk-test
+  "qualified import"
+  (hk-parse-top "import qualified Data.Map")
+  (list
+    :module
+    nil
+    nil
+    (list (list :import true "Data.Map" nil nil))
+    (list)))
+
+(hk-test
+  "import with alias"
+  (hk-parse-top "import Data.Map as M")
+  (list
+    :module
+    nil
+    nil
+    (list (list :import false "Data.Map" "M" nil))
+    (list)))
+
+(hk-test
+  "import with explicit list"
+  (hk-parse-top "import Foo (bar, Baz(..), Quux(X, Y))")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list
+        :import
+        false
+        "Foo"
+        nil
+        (list
+          :spec-items
+          (list
+            (list :ent-var "bar")
+            (list :ent-all "Baz")
+            (list :ent-with "Quux" (list "X" "Y"))))))
+    (list)))
+
+(hk-test
+  "import hiding"
+  (hk-parse-top "import Foo hiding (x, y)")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list
+        :import
+        false
+        "Foo"
+        nil
+        (list
+          :spec-hiding
+          (list (list :ent-var "x") (list :ent-var "y")))))
+    (list)))
+
+(hk-test
+  "qualified + alias + hiding"
+  (hk-parse-top "import qualified Data.List as L hiding (sort)")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list
+        :import
+        true
+        "Data.List"
+        "L"
+        (list :spec-hiding (list (list :ent-var "sort")))))
+    (list)))
+
+;; ── Combinations ──
+(hk-test
+  "module with multiple imports and a decl"
+  (hk-parse-top "module M where\nimport Foo\nimport qualified Bar as B\nf = 1")
+  (list
+    :module
+    "M"
+    nil
+    (list
+      (list :import false "Foo" nil nil)
+      (list :import true "Bar" "B" nil))
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "headerless file with imports"
+  (hk-parse-top "import Foo\nimport Bar (baz)\nf = 1")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list :import false "Foo" nil nil)
+      (list
+        :import
+        false
+        "Bar"
+        nil
+        (list :spec-items (list (list :ent-var "baz")))))
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "plain program (no header, no imports) still uses :program"
+  (hk-parse-top "f = 1\ng = 2")
+  (list
+    :program
+    (list
+      (list :fun-clause "f" (list) (list :int 1))
+      (list :fun-clause "g" (list) (list :int 2)))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-patterns.sx

@@ -0,0 +1,234 @@
+;; Full-pattern parser tests: as-patterns, lazy ~, negative literals,
+;; infix constructor patterns (`:`, any consym), lambda pattern args,
+;; and let pattern-bindings.
+
+;; ── as-patterns ──
+(hk-test
+  "as pattern, wraps constructor"
+  (hk-parse "case x of n@(Just y) -> n")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list
+          :p-as
+          "n"
+          (list :p-con "Just" (list (list :p-var "y"))))
+        (list :var "n")))))
+
+(hk-test
+  "as pattern, wraps wildcard"
+  (hk-parse "case x of all@_ -> all")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-as "all" (list :p-wild))
+        (list :var "all")))))
+
+(hk-test
+  "as in lambda"
+  (hk-parse "\\xs@(a : rest) -> xs")
+  (list
+    :lambda
+    (list
+      (list
+        :p-as
+        "xs"
+        (list
+          :p-con
+          ":"
+          (list (list :p-var "a") (list :p-var "rest")))))
+    (list :var "xs")))
+
+;; ── lazy patterns ──
+(hk-test
+  "lazy var"
+  (hk-parse "case x of ~y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-lazy (list :p-var "y")) (list :var "y")))))
+
+(hk-test
+  "lazy constructor"
+  (hk-parse "\\(~(Just x)) -> x")
+  (list
+    :lambda
+    (list
+      (list
+        :p-lazy
+        (list :p-con "Just" (list (list :p-var "x")))))
+    (list :var "x")))
+
+;; ── negative literal patterns ──
+(hk-test
+  "negative int pattern"
+  (hk-parse "case n of\n  -1 -> 0\n  _ -> n")
+  (list
+    :case
+    (list :var "n")
+    (list
+      (list :alt (list :p-int -1) (list :int 0))
+      (list :alt (list :p-wild) (list :var "n")))))
+
+(hk-test
+  "negative float pattern"
+  (hk-parse "case x of -0.5 -> 1")
+  (list
+    :case
+    (list :var "x")
+    (list (list :alt (list :p-float -0.5) (list :int 1)))))
+
+;; ── infix constructor patterns (`:` and any consym) ──
+(hk-test
+  "cons pattern"
+  (hk-parse "case xs of x : rest -> x")
+  (list
+    :case
+    (list :var "xs")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          ":"
+          (list (list :p-var "x") (list :p-var "rest")))
+        (list :var "x")))))
+
+(hk-test
+  "cons is right-associative in pats"
+  (hk-parse "case xs of a : b : rest -> rest")
+  (list
+    :case
+    (list :var "xs")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          ":"
+          (list
+            (list :p-var "a")
+            (list
+              :p-con
+              ":"
+              (list (list :p-var "b") (list :p-var "rest")))))
+        (list :var "rest")))))
+
+(hk-test
+  "consym pattern"
+  (hk-parse "case p of a :+: b -> a")
+  (list
+    :case
+    (list :var "p")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          ":+:"
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+;; ── lambda with pattern args ──
+(hk-test
+  "lambda with constructor pattern"
+  (hk-parse "\\(Just x) -> x")
+  (list
+    :lambda
+    (list (list :p-con "Just" (list (list :p-var "x"))))
+    (list :var "x")))
+
+(hk-test
+  "lambda with tuple pattern"
+  (hk-parse "\\(a, b) -> a + b")
+  (list
+    :lambda
+    (list
+      (list
+        :p-tuple
+        (list (list :p-var "a") (list :p-var "b"))))
+    (list :op "+" (list :var "a") (list :var "b"))))
+
+(hk-test
+  "lambda with wildcard"
+  (hk-parse "\\_ -> 42")
+  (list :lambda (list (list :p-wild)) (list :int 42)))
+
+(hk-test
+  "lambda with mixed apats"
+  (hk-parse "\\x _ (Just y) -> y")
+  (list
+    :lambda
+    (list
+      (list :p-var "x")
+      (list :p-wild)
+      (list :p-con "Just" (list (list :p-var "y"))))
+    (list :var "y")))
+
+;; ── let pattern-bindings ──
+(hk-test
+  "let tuple pattern-binding"
+  (hk-parse "let (x, y) = pair in x + y")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list
+          :p-tuple
+          (list (list :p-var "x") (list :p-var "y")))
+        (list :var "pair")))
+    (list :op "+" (list :var "x") (list :var "y"))))
+
+(hk-test
+  "let constructor pattern-binding"
+  (hk-parse "let Just x = m in x")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list :p-con "Just" (list (list :p-var "x")))
+        (list :var "m")))
+    (list :var "x")))
+
+(hk-test
+  "let cons pattern-binding"
+  (hk-parse "let (x : rest) = xs in x")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list
+          :p-con
+          ":"
+          (list (list :p-var "x") (list :p-var "rest")))
+        (list :var "xs")))
+    (list :var "x")))
+
+;; ── do with constructor-pattern binds ──
+(hk-test
+  "do bind to tuple pattern"
+  (hk-parse "do\n  (a, b) <- pairs\n  return a")
+  (list
+    :do
+    (list
+      (list
+        :do-bind
+        (list
+          :p-tuple
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "pairs"))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :var "a"))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-sect-comp.sx

@@ -0,0 +1,191 @@
+;; Operator sections and list comprehensions.
+
+;; ── Operator references (unchanged expr shape) ──
+(hk-test
+  "op as value (+)"
+  (hk-parse "(+)")
+  (list :var "+"))
+
+(hk-test
+  "op as value (-)"
+  (hk-parse "(-)")
+  (list :var "-"))
+
+(hk-test
+  "op as value (:)"
+  (hk-parse "(:)")
+  (list :var ":"))
+
+(hk-test
+  "backtick op as value"
+  (hk-parse "(`div`)")
+  (list :var "div"))
+
+;; ── Right sections (op expr) ──
+(hk-test
+  "right section (+ 5)"
+  (hk-parse "(+ 5)")
+  (list :sect-right "+" (list :int 5)))
+
+(hk-test
+  "right section (* x)"
+  (hk-parse "(* x)")
+  (list :sect-right "*" (list :var "x")))
+
+(hk-test
+  "right section with backtick op"
+  (hk-parse "(`div` 2)")
+  (list :sect-right "div" (list :int 2)))
+
+;; `-` is unary in expr position — (- 5) is negation, not a right section
+(hk-test
+  "(- 5) is negation, not a section"
+  (hk-parse "(- 5)")
+  (list :neg (list :int 5)))
+
+;; ── Left sections (expr op) ──
+(hk-test
+  "left section (5 +)"
+  (hk-parse "(5 +)")
+  (list :sect-left "+" (list :int 5)))
+
+(hk-test
+  "left section with backtick"
+  (hk-parse "(x `mod`)")
+  (list :sect-left "mod" (list :var "x")))
+
+(hk-test
+  "left section with cons (x :)"
+  (hk-parse "(x :)")
+  (list :sect-left ":" (list :var "x")))
+
+;; ── Mixed / nesting ──
+(hk-test
+  "map (+ 1) xs"
+  (hk-parse "map (+ 1) xs")
+  (list
+    :app
+    (list
+      :app
+      (list :var "map")
+      (list :sect-right "+" (list :int 1)))
+    (list :var "xs")))
+
+(hk-test
+  "filter (< 0) xs"
+  (hk-parse "filter (< 0) xs")
+  (list
+    :app
+    (list
+      :app
+      (list :var "filter")
+      (list :sect-right "<" (list :int 0)))
+    (list :var "xs")))
+
+;; ── Plain parens and tuples still work ──
+(hk-test
+  "plain parens unwrap"
+  (hk-parse "(1 + 2)")
+  (list :op "+" (list :int 1) (list :int 2)))
+
+(hk-test
+  "tuple still parses"
+  (hk-parse "(a, b, c)")
+  (list
+    :tuple
+    (list (list :var "a") (list :var "b") (list :var "c"))))
+
+;; ── List comprehensions ──
+(hk-test
+  "simple list comprehension"
+  (hk-parse "[x | x <- xs]")
+  (list
+    :list-comp
+    (list :var "x")
+    (list
+      (list :q-gen (list :p-var "x") (list :var "xs")))))
+
+(hk-test
+  "comprehension with filter"
+  (hk-parse "[x * 2 | x <- xs, x > 0]")
+  (list
+    :list-comp
+    (list :op "*" (list :var "x") (list :int 2))
+    (list
+      (list :q-gen (list :p-var "x") (list :var "xs"))
+      (list
+        :q-guard
+        (list :op ">" (list :var "x") (list :int 0))))))
+
+(hk-test
+  "comprehension with let"
+  (hk-parse "[y | x <- xs, let y = x + 1]")
+  (list
+    :list-comp
+    (list :var "y")
+    (list
+      (list :q-gen (list :p-var "x") (list :var "xs"))
+      (list
+        :q-let
+        (list
+          (list
+            :bind
+            (list :p-var "y")
+            (list :op "+" (list :var "x") (list :int 1))))))))
+
+(hk-test
+  "nested generators"
+  (hk-parse "[(x, y) | x <- xs, y <- ys]")
+  (list
+    :list-comp
+    (list :tuple (list (list :var "x") (list :var "y")))
+    (list
+      (list :q-gen (list :p-var "x") (list :var "xs"))
+      (list :q-gen (list :p-var "y") (list :var "ys")))))
+
+(hk-test
+  "comprehension with constructor pattern"
+  (hk-parse "[v | Just v <- xs]")
+  (list
+    :list-comp
+    (list :var "v")
+    (list
+      (list
+        :q-gen
+        (list :p-con "Just" (list (list :p-var "v")))
+        (list :var "xs")))))
+
+(hk-test
+  "comprehension with tuple pattern"
+  (hk-parse "[x + y | (x, y) <- pairs]")
+  (list
+    :list-comp
+    (list :op "+" (list :var "x") (list :var "y"))
+    (list
+      (list
+        :q-gen
+        (list
+          :p-tuple
+          (list (list :p-var "x") (list :p-var "y")))
+        (list :var "pairs")))))
+
+(hk-test
+  "combination: generator, let, guard"
+  (hk-parse "[z | x <- xs, let z = x * 2, z > 10]")
+  (list
+    :list-comp
+    (list :var "z")
+    (list
+      (list :q-gen (list :p-var "x") (list :var "xs"))
+      (list
+        :q-let
+        (list
+          (list
+            :bind
+            (list :p-var "z")
+            (list :op "*" (list :var "x") (list :int 2)))))
+      (list
+        :q-guard
+        (list :op ">" (list :var "z") (list :int 10))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-fib.sx

@@ -0,0 +1,45 @@
+;; fib.hs — infinite Fibonacci stream classic program.
+;;
+;; The canonical artefact lives at lib/haskell/tests/programs/fib.hs.
+;; The source is mirrored here as an SX string because the evaluator
+;; doesn't have read-file in the default env. If you change one, keep
+;; the other in sync — there's a runner-level cross-check against the
+;; expected first-15 list.
+
+(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-fib-source
+  "zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys
+zipPlus _ _ = []
+myFibs = 0 : 1 : zipPlus myFibs (tail myFibs)
+result = take 15 myFibs
+")
+
+(hk-test
+  "fib.hs — first 15 Fibonacci numbers"
+  (hk-as-list (hk-prog-val hk-fib-source "result"))
+  (list 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377))
+
+;; Spot-check that the user-defined zipPlus is also reachable
+(hk-test
+  "fib.hs — zipPlus is a multi-clause user fn"
+  (hk-as-list
+    (hk-prog-val
+      (str hk-fib-source "extra = zipPlus [1, 2, 3] [10, 20, 30]\n")
+      "extra"))
+  (list 11 22 33))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/programs/fib.hs

@@ -0,0 +1,15 @@
+-- fib.hs — infinite Fibonacci stream.
+--
+-- The classic two-line definition: `fibs` is a self-referential
+-- lazy list built by zipping itself with its own tail, summing the
+-- pair at each step. Without lazy `:` (cons cell with thunked head
+-- and tail) this would diverge before producing any output; with
+-- it, `take 15 fibs` evaluates exactly as much of the spine as
+-- demanded.
+
+zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys
+zipPlus _ _ = []
+
+myFibs = 0 : 1 : zipPlus myFibs (tail myFibs)
+
+result = take 15 myFibs

lib/haskell/tests/runtime.sx

@@ -0,0 +1,127 @@
+;; Runtime constructor-registry tests. Built-ins are pre-registered
+;; when lib/haskell/runtime.sx loads; user types are registered by
+;; walking a parsed+desugared AST with hk-register-program! (or the
+;; `hk-load-source!` convenience).
+
+;; ── Pre-registered built-ins ──
+(hk-test "True is a con" (hk-is-con? "True") true)
+(hk-test "False is a con" (hk-is-con? "False") true)
+(hk-test "[] is a con" (hk-is-con? "[]") true)
+(hk-test ": (cons) is a con" (hk-is-con? ":") true)
+(hk-test "() is a con" (hk-is-con? "()") true)
+
+(hk-test "True arity 0" (hk-con-arity "True") 0)
+(hk-test ": arity 2" (hk-con-arity ":") 2)
+(hk-test "[] arity 0" (hk-con-arity "[]") 0)
+(hk-test "True type Bool" (hk-con-type "True") "Bool")
+(hk-test "False type Bool" (hk-con-type "False") "Bool")
+(hk-test ": type List" (hk-con-type ":") "List")
+(hk-test "() type Unit" (hk-con-type "()") "Unit")
+
+;; ── Unknown names ──
+(hk-test "is-con? false for varid" (hk-is-con? "foo") false)
+(hk-test "arity nil for unknown" (hk-con-arity "NotACon") nil)
+(hk-test "type nil for unknown" (hk-con-type "NotACon") nil)
+
+;; ── data MyBool = Yes | No ──
+(hk-test
+  "register simple data"
+  (do
+    (hk-load-source! "data MyBool = Yes | No")
+    (list
+      (hk-con-arity "Yes")
+      (hk-con-arity "No")
+      (hk-con-type "Yes")
+      (hk-con-type "No")))
+  (list 0 0 "MyBool" "MyBool"))
+
+;; ── data Maybe a = Nothing | Just a ──
+(hk-test
+  "register Maybe"
+  (do
+    (hk-load-source! "data Maybe a = Nothing | Just a")
+    (list
+      (hk-con-arity "Nothing")
+      (hk-con-arity "Just")
+      (hk-con-type "Nothing")
+      (hk-con-type "Just")))
+  (list 0 1 "Maybe" "Maybe"))
+
+;; ── data Either a b = Left a | Right b ──
+(hk-test
+  "register Either"
+  (do
+    (hk-load-source! "data Either a b = Left a | Right b")
+    (list
+      (hk-con-arity "Left")
+      (hk-con-arity "Right")
+      (hk-con-type "Left")
+      (hk-con-type "Right")))
+  (list 1 1 "Either" "Either"))
+
+;; ── Recursive data ──
+(hk-test
+  "register recursive Tree"
+  (do
+    (hk-load-source!
+      "data Tree a = Leaf | Node (Tree a) a (Tree a)")
+    (list
+      (hk-con-arity "Leaf")
+      (hk-con-arity "Node")
+      (hk-con-type "Leaf")
+      (hk-con-type "Node")))
+  (list 0 3 "Tree" "Tree"))
+
+;; ── newtype ──
+(hk-test
+  "register newtype"
+  (do
+    (hk-load-source! "newtype Age = MkAge Int")
+    (list
+      (hk-con-arity "MkAge")
+      (hk-con-type "MkAge")))
+  (list 1 "Age"))
+
+;; ── Multiple data decls in one program ──
+(hk-test
+  "multiple data decls"
+  (do
+    (hk-load-source!
+      "data Color = Red | Green | Blue\ndata Shape = Circle | Square\nf x = x")
+    (list
+      (hk-con-type "Red")
+      (hk-con-type "Green")
+      (hk-con-type "Blue")
+      (hk-con-type "Circle")
+      (hk-con-type "Square")))
+  (list "Color" "Color" "Color" "Shape" "Shape"))
+
+;; ── Inside a module header ──
+(hk-test
+  "register from module body"
+  (do
+    (hk-load-source!
+      "module M where\ndata Pair a = Pair a a")
+    (list
+      (hk-con-arity "Pair")
+      (hk-con-type "Pair")))
+  (list 2 "Pair"))
+
+;; ── Non-data decls are ignored ──
+(hk-test
+  "program with only fun-decl leaves registry unchanged for that name"
+  (do
+    (hk-load-source! "myFunctionNotACon x = x + 1")
+    (hk-is-con? "myFunctionNotACon"))
+  false)
+
+;; ── Re-registering overwrites (last wins) ──
+(hk-test
+  "re-registration overwrites the entry"
+  (do
+    (hk-load-source! "data Foo = Bar Int")
+    (hk-load-source! "data Foo = Bar Int Int")
+    (hk-con-arity "Bar"))
+  2)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/seq.sx

@@ -0,0 +1,85 @@
+;; seq / deepseq tests. seq is strict in its first arg (forces to
+;; WHNF) and returns the second arg unchanged. deepseq additionally
+;; forces the first arg to normal form.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define hk-as-list
+  (fn (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(define
+  hk-eval-list
+  (fn (src) (hk-as-list (hk-eval-expr-source src))))
+
+;; ── seq returns its second arg ──
+(hk-test
+  "seq with primitive first arg"
+  (hk-eval-expr-source "seq 1 99")
+  99)
+
+(hk-test
+  "seq forces first arg via let"
+  (hk-eval-expr-source "let x = 1 + 2 in seq x x")
+  3)
+
+(hk-test
+  "seq second arg is whatever shape"
+  (hk-eval-expr-source "seq 0 \"hello\"")
+  "hello")
+
+;; ── seq enables previously-lazy bottom to be forced ──
+;; Without seq the let-binding `x = error …` is never forced;
+;; with seq it must be forced because seq is strict in its first
+;; argument. We don't run that error case here (it would terminate
+;; the test), but we do verify the negative — that without seq,
+;; the bottom bound is never demanded.
+(hk-test
+  "lazy let — bottom never forced when unused"
+  (hk-eval-expr-source "let x = error \"never\" in 42")
+  42)
+
+;; ── deepseq forces nested structure ──
+(hk-test
+  "deepseq with finite list"
+  (hk-eval-expr-source "deepseq [1, 2, 3] 7")
+  7)
+
+(hk-test
+  "deepseq with constructor value"
+  (hk-eval-expr-source "deepseq (Just 5) 11")
+  11)
+
+(hk-test
+  "deepseq with tuple"
+  (hk-eval-expr-source "deepseq (1, 2) 13")
+  13)
+
+;; ── seq + arithmetic ──
+(hk-test
+  "seq used inside arithmetic doesn't poison the result"
+  (hk-eval-expr-source "(seq 1 5) + (seq 2 7)")
+  12)
+
+;; ── seq in user code ──
+(hk-test
+  "seq via fun-clause"
+  (hk-prog-val
+    "f x = seq x (x + 1)\nresult = f 10"
+    "result")
+  11)
+
+(hk-test
+  "seq sequences list construction"
+  (hk-eval-list "[seq 1 10, seq 2 20]")
+  (list 10 20))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/prolog/conformance.sh

@@ -1,110 +0,0 @@
-#!/usr/bin/env bash
-# Run every Prolog test suite via sx_server and refresh scoreboard.{json,md}.
-# Exit 0 if all green, 1 if any failures.
-set -euo pipefail
-
-HERE="$(cd "$(dirname "$0")" && pwd)"
-ROOT="$(cd "$HERE/../.." && pwd)"
-SX="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
-
-if [[ ! -x "$SX" ]]; then
-  echo "sx_server not found at $SX (set SX_SERVER env to override)" >&2
-  exit 2
-fi
-
-cd "$ROOT"
-
-# name : test-file : runner-fn
-SUITES=(
-  "parse:lib/prolog/tests/parse.sx:pl-parse-tests-run!"
-  "unify:lib/prolog/tests/unify.sx:pl-unify-tests-run!"
-  "clausedb:lib/prolog/tests/clausedb.sx:pl-clausedb-tests-run!"
-  "solve:lib/prolog/tests/solve.sx:pl-solve-tests-run!"
-  "operators:lib/prolog/tests/operators.sx:pl-operators-tests-run!"
-  "dynamic:lib/prolog/tests/dynamic.sx:pl-dynamic-tests-run!"
-  "findall:lib/prolog/tests/findall.sx:pl-findall-tests-run!"
-  "term_inspect:lib/prolog/tests/term_inspect.sx:pl-term-inspect-tests-run!"
-  "append:lib/prolog/tests/programs/append.sx:pl-append-tests-run!"
-  "reverse:lib/prolog/tests/programs/reverse.sx:pl-reverse-tests-run!"
-  "member:lib/prolog/tests/programs/member.sx:pl-member-tests-run!"
-  "nqueens:lib/prolog/tests/programs/nqueens.sx:pl-nqueens-tests-run!"
-  "family:lib/prolog/tests/programs/family.sx:pl-family-tests-run!"
-)
-
-SCRIPT='(epoch 1)
-(load "lib/prolog/tokenizer.sx")
-(load "lib/prolog/parser.sx")
-(load "lib/prolog/runtime.sx")'
-for entry in "${SUITES[@]}"; do
-  IFS=: read -r _ file _ <<< "$entry"
-  SCRIPT+=$'\n(load "'"$file"$'")'
-done
-for entry in "${SUITES[@]}"; do
-  IFS=: read -r _ _ fn <<< "$entry"
-  SCRIPT+=$'\n(eval "('"$fn"$')")'
-done
-
-OUTPUT="$(printf '%s\n' "$SCRIPT" | "$SX" 2>&1)"
-
-mapfile -t LINES < <(printf '%s\n' "$OUTPUT" | grep -E '^\{:failed')
-
-if [[ ${#LINES[@]} -ne ${#SUITES[@]} ]]; then
-  echo "Expected ${#SUITES[@]} suite results, got ${#LINES[@]}" >&2
-  echo "---- raw output ----" >&2
-  printf '%s\n' "$OUTPUT" >&2
-  exit 3
-fi
-
-TOTAL_PASS=0
-TOTAL_FAIL=0
-TOTAL=0
-JSON_SUITES=""
-MD_ROWS=""
-
-for i in "${!SUITES[@]}"; do
-  IFS=: read -r name _ _ <<< "${SUITES[$i]}"
-  line="${LINES[$i]}"
-  passed=$(grep -oE ':passed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
-  total=$(grep -oE ':total [0-9]+' <<< "$line" | grep -oE '[0-9]+')
-  failed=$(grep -oE ':failed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
-  TOTAL_PASS=$((TOTAL_PASS + passed))
-  TOTAL_FAIL=$((TOTAL_FAIL + failed))
-  TOTAL=$((TOTAL + total))
-  status="ok"
-  [[ "$failed" -gt 0 ]] && status="FAIL"
-  [[ -n "$JSON_SUITES" ]] && JSON_SUITES+=","
-  JSON_SUITES+="\"$name\":{\"passed\":$passed,\"total\":$total,\"failed\":$failed}"
-  MD_ROWS+="| $name | $passed | $total | $status |"$'\n'
-done
-
-WHEN="$(date -Iseconds 2>/dev/null || date)"
-
-cat > "$HERE/scoreboard.json" <<JSON
-{
-  "total_passed": $TOTAL_PASS,
-  "total_failed": $TOTAL_FAIL,
-  "total": $TOTAL,
-  "suites": {$JSON_SUITES},
-  "generated": "$WHEN"
-}
-JSON
-
-cat > "$HERE/scoreboard.md" <<MD
-# Prolog scoreboard
-
-**$TOTAL_PASS / $TOTAL passing** ($TOTAL_FAIL failure(s)).
-Generated $WHEN.
-
-| Suite | Passed | Total | Status |
-|-------|--------|-------|--------|
-$MD_ROWS
-Run \`bash lib/prolog/conformance.sh\` to refresh. Override the binary
-with \`SX_SERVER=path/to/sx_server.exe bash …\`.
-MD
-
-if [[ "$TOTAL_FAIL" -gt 0 ]]; then
-  echo "$TOTAL_FAIL failure(s) across $TOTAL tests" >&2
-  exit 1
-fi
-
-echo "All $TOTAL tests pass."

lib/prolog/parser.sx

@@ -1,20 +1,28 @@
 ;; lib/prolog/parser.sx — tokens → Prolog AST
 ;;
-;; Phase 4 grammar (with operator table):
+;; Phase 1 grammar (NO operator table yet):
 ;;   Program      := Clause* EOF
-;;   Clause       := Term[999] "." | Term[999] ":-" Term[1200] "."
+;;   Clause       := Term "." | Term ":-" Term "."
-;;   Term[Pmax] uses precedence climbing on the operator table:
+;;   Term         := Atom | Var | Number | String | Compound | List
-;;     primary = Atom | Var | Number | String | Compound | List | "(" Term[1200] ")"
+;;   Compound     := atom "(" ArgList ")"
-;;     while next token is infix op `op` with prec(op) ≤ Pmax:
+;;   ArgList      := Term ("," Term)*
-;;       consume op; parse rhs at right-prec(op); fold into compound(op-name,[lhs,rhs])
+;;   List         := "[" "]" | "[" Term ("," Term)* ("|" Term)? "]"
 ;;
-;; Op type → right-prec for op at precedence P:
+;; Term AST shapes (all tagged lists for uniform dispatch):
-;;   xfx → P-1   strict-both
+;;   ("atom"  name)            — atom
-;;   xfy → P     right-associative
+;;   ("var"   name)            — variable template (parser-time only)
-;;   yfx → P-1   left-associative
+;;   ("num"   value)           — integer or float
+;;   ("str"   value)           — string literal
+;;   ("compound" functor args) — compound term, args is list of term-ASTs
+;;   ("cut")                   — the cut atom !
 ;;
-;; AST shapes are unchanged — operators just become compound terms.
+;; A clause is (list "clause" head body). A fact is head with body = ("atom" "true").
+;;
+;; The empty list is (atom "[]"). Cons is compound "." with two args:
+;; [1, 2, 3]   → .(1, .(2, .(3, [])))
+;; [H|T]       → .(H, T)
 
+;; ── Parser state helpers ────────────────────────────────────────────
 (define
   pp-peek
   (fn
@@ -58,6 +66,7 @@
             (if (= (get t :value) nil) "" (get t :value))
             "'"))))))
 
+;; ── AST constructors ────────────────────────────────────────────────
 (define pl-mk-atom (fn (name) (list "atom" name)))
 (define pl-mk-var (fn (name) (list "var" name)))
 (define pl-mk-num (fn (n) (list "num" n)))
@@ -65,14 +74,18 @@
 (define pl-mk-compound (fn (f args) (list "compound" f args)))
 (define pl-mk-cut (fn () (list "cut")))
 
+;; Term tag extractors
 (define pl-term-tag (fn (t) (if (list? t) (first t) nil)))
 (define pl-term-val (fn (t) (nth t 1)))
 (define pl-compound-functor (fn (t) (nth t 1)))
 (define pl-compound-args (fn (t) (nth t 2)))
 
+;; Empty-list atom and cons helpers
 (define pl-nil-term (fn () (pl-mk-atom "[]")))
+
 (define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t))))
 
+;; Build cons list from a list of terms + optional tail
 (define
   pl-mk-list-term
   (fn
@@ -82,60 +95,9 @@
       tail
       (pl-mk-cons (first items) (pl-mk-list-term (rest items) tail)))))
 
-;; ── Operator table (Phase 4) ──────────────────────────────────────
-;; Each entry: (name precedence type). Type ∈ "xfx" "xfy" "yfx".
-(define
-  pl-op-table
-  (list
-    (list "," 1000 "xfy")
-    (list ";" 1100 "xfy")
-    (list "->" 1050 "xfy")
-    (list "=" 700 "xfx")
-    (list "\\=" 700 "xfx")
-    (list "is" 700 "xfx")
-    (list "<" 700 "xfx")
-    (list ">" 700 "xfx")
-    (list "=<" 700 "xfx")
-    (list ">=" 700 "xfx")
-    (list "+" 500 "yfx")
-    (list "-" 500 "yfx")
-    (list "*" 400 "yfx")
-    (list "/" 400 "yfx")
-    (list "mod" 400 "yfx")))
-
-(define
-  pl-op-find
-  (fn
-    (name table)
-    (cond
-      ((empty? table) nil)
-      ((= (first (first table)) name) (rest (first table)))
-      (true (pl-op-find name (rest table))))))
-
-(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table)))
-
-;; Token → (name prec type) for known infix ops, else nil.
-(define
-  pl-token-op
-  (fn
-    (t)
-    (let
-      ((ty (get t :type)) (vv (get t :value)))
-      (cond
-        ((and (= ty "punct") (= vv ","))
-          (let
-            ((info (pl-op-lookup ",")))
-            (if (nil? info) nil (cons "," info))))
-        ((= ty "atom")
-          (let
-            ((info (pl-op-lookup vv)))
-            (if (nil? info) nil (cons vv info))))
-        (true nil)))))
-
 ;; ── Term parser ─────────────────────────────────────────────────────
-;; Primary term: atom, var, num, str, compound (atom + paren), list, cut, parens.
 (define
-  pp-parse-primary
+  pp-parse-term
   (fn
     (st)
     (let
@@ -149,12 +111,6 @@
           ((and (= ty "op") (= vv "!"))
             (do (pp-advance! st) (pl-mk-cut)))
           ((and (= ty "punct") (= vv "[")) (pp-parse-list st))
-          ((and (= ty "punct") (= vv "("))
-            (do
-              (pp-advance! st)
-              (let
-                ((inner (pp-parse-term-prec st 1200)))
-                (do (pp-expect! st "punct" ")") inner))))
           ((= ty "atom")
             (do
               (pp-advance! st)
@@ -177,51 +133,13 @@
                 (if (= vv nil) "" vv)
                 "'"))))))))
 
-;; Operator-aware term parser: precedence climbing.
+;; Parse one or more comma-separated terms (arguments).
-(define
-  pp-parse-term-prec
-  (fn
-    (st max-prec)
-    (let ((left (pp-parse-primary st))) (pp-parse-op-rhs st left max-prec))))
-
-(define
-  pp-parse-op-rhs
-  (fn
-    (st left max-prec)
-    (let
-      ((op-info (pl-token-op (pp-peek st))))
-      (cond
-        ((nil? op-info) left)
-        (true
-          (let
-            ((name (first op-info))
-              (prec (nth op-info 1))
-              (ty (nth op-info 2)))
-            (cond
-              ((> prec max-prec) left)
-              (true
-                (let
-                  ((right-prec (if (= ty "xfy") prec (- prec 1))))
-                  (do
-                    (pp-advance! st)
-                    (let
-                      ((right (pp-parse-term-prec st right-prec)))
-                      (pp-parse-op-rhs
-                        st
-                        (pl-mk-compound name (list left right))
-                        max-prec))))))))))))
-
-;; Backwards-compat alias.
-(define pp-parse-term (fn (st) (pp-parse-term-prec st 999)))
-
-;; Args inside parens: parse at prec 999 so comma-as-operator (1000)
-;; is not consumed; the explicit comma loop handles separation.
 (define
   pp-parse-arg-list
   (fn
     (st)
     (let
-      ((first-arg (pp-parse-term-prec st 999)) (args (list)))
+      ((first-arg (pp-parse-term st)) (args (list)))
       (do
         (append! args first-arg)
         (define
@@ -232,12 +150,12 @@
               (pp-at? st "punct" ",")
               (do
                 (pp-advance! st)
-                (append! args (pp-parse-term-prec st 999))
+                (append! args (pp-parse-term st))
                 (loop)))))
         (loop)
         args))))
 
-;; List literal.
+;; Parse a [ ... ] list literal. Consumes the "[".
 (define
   pp-parse-list
   (fn
@@ -250,7 +168,7 @@
         (let
           ((items (list)))
           (do
-            (append! items (pp-parse-term-prec st 999))
+            (append! items (pp-parse-term st))
             (define
               comma-loop
               (fn
@@ -259,17 +177,52 @@
                   (pp-at? st "punct" ",")
                   (do
                     (pp-advance! st)
-                    (append! items (pp-parse-term-prec st 999))
+                    (append! items (pp-parse-term st))
                     (comma-loop)))))
             (comma-loop)
             (let
-              ((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term-prec st 999)) (pl-nil-term))))
+              ((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term st)) (pl-nil-term))))
               (do (pp-expect! st "punct" "]") (pl-mk-list-term items tail)))))))))
 
 ;; ── Body parsing ────────────────────────────────────────────────────
-;; A body is a single term parsed at prec 1200 — operator parser folds
+;; A clause body is a comma-separated list of goals. We flatten into a
-;; `,`, `;`, `->` automatically into right-associative compounds.
+;; right-associative `,` compound: (A, B, C) → ','(A, ','(B, C))
-(define pp-parse-body (fn (st) (pp-parse-term-prec st 1200)))
+;; If only one goal, it's that goal directly.
+(define
+  pp-parse-body
+  (fn
+    (st)
+    (let
+      ((first-goal (pp-parse-term st)) (rest-goals (list)))
+      (do
+        (define
+          gloop
+          (fn
+            ()
+            (when
+              (pp-at? st "punct" ",")
+              (do
+                (pp-advance! st)
+                (append! rest-goals (pp-parse-term st))
+                (gloop)))))
+        (gloop)
+        (if
+          (= (len rest-goals) 0)
+          first-goal
+          (pp-build-conj first-goal rest-goals))))))
+
+(define
+  pp-build-conj
+  (fn
+    (first-goal rest-goals)
+    (if
+      (= (len rest-goals) 0)
+      first-goal
+      (pl-mk-compound
+        ","
+        (list
+          first-goal
+          (pp-build-conj (first rest-goals) (rest rest-goals)))))))
 
 ;; ── Clause parsing ──────────────────────────────────────────────────
 (define
@@ -277,11 +230,12 @@
   (fn
     (st)
     (let
-      ((head (pp-parse-term-prec st 999)))
+      ((head (pp-parse-term st)))
       (let
         ((body (if (pp-at? st "op" ":-") (do (pp-advance! st) (pp-parse-body st)) (pl-mk-atom "true"))))
         (do (pp-expect! st "punct" ".") (list "clause" head body))))))
 
+;; Parse an entire program — returns list of clauses.
 (define
   pl-parse-program
   (fn
@@ -299,9 +253,13 @@
         (ploop)
         clauses))))
 
+;; Parse a single query term (no trailing "."). Returns the term.
 (define
   pl-parse-query
   (fn (tokens) (let ((st {:idx 0 :tokens tokens})) (pp-parse-body st))))
 
+;; Convenience: source → clauses
 (define pl-parse (fn (src) (pl-parse-program (pl-tokenize src))))
+
+;; Convenience: source → query term
 (define pl-parse-goal (fn (src) (pl-parse-query (pl-tokenize src))))

lib/prolog/runtime.sx

@@ -98,11 +98,6 @@
             "compound"
             fun
             (map (fn (a) (pl-instantiate a var-env)) args))))
-      ((= (first ast) "clause")
-        (let
-          ((h (pl-instantiate (nth ast 1) var-env))
-            (b (pl-instantiate (nth ast 2) var-env)))
-          (list "clause" h b)))
       (true ast))))
 
 (define pl-instantiate-fresh (fn (ast) (pl-instantiate ast {})))
@@ -235,733 +230,3 @@
         (pl-unify! t1 t2 trail)
         true
         (do (pl-trail-undo-to! trail mark) false)))))
-
-(define pl-mk-db (fn () {:clauses {}}))
-
-(define
-  pl-head-key
-  (fn
-    (head)
-    (cond
-      ((pl-compound? head) (str (pl-fun head) "/" (len (pl-args head))))
-      ((pl-atom? head) (str (pl-atom-name head) "/0"))
-      (true (error "pl-head-key: invalid head")))))
-
-(define pl-clause-key (fn (clause) (pl-head-key (nth clause 1))))
-
-(define pl-goal-key (fn (goal) (pl-head-key goal)))
-
-(define
-  pl-db-add!
-  (fn
-    (db clause)
-    (let
-      ((key (pl-clause-key clause)) (table (dict-get db :clauses)))
-      (cond
-        ((nil? (dict-get table key)) (dict-set! table key (list clause)))
-        (true (begin (append! (dict-get table key) clause) nil))))))
-
-(define
-  pl-db-load!
-  (fn
-    (db program)
-    (cond
-      ((empty? program) nil)
-      (true
-        (begin
-          (pl-db-add! db (first program))
-          (pl-db-load! db (rest program)))))))
-
-(define
-  pl-db-lookup
-  (fn
-    (db key)
-    (let
-      ((v (dict-get (dict-get db :clauses) key)))
-      (cond ((nil? v) (list)) (true v)))))
-
-(define
-  pl-db-lookup-goal
-  (fn (db goal) (pl-db-lookup db (pl-goal-key goal))))
-
-(define
-  pl-rt-walk-to-ast
-  (fn
-    (w)
-    (cond
-      ((pl-var? w) (list "var" (str "_G" (pl-var-id w))))
-      ((and (list? w) (not (empty? w)) (= (first w) "compound"))
-        (list "compound" (nth w 1) (map pl-rt-walk-to-ast (nth w 2))))
-      (true w))))
-
-(define pl-rt-to-ast (fn (t) (pl-rt-walk-to-ast (pl-walk-deep t))))
-
-(define
-  pl-build-clause
-  (fn
-    (ast)
-    (cond
-      ((and (list? ast) (= (first ast) "compound") (= (nth ast 1) ":-") (= (len (nth ast 2)) 2))
-        (list "clause" (first (nth ast 2)) (nth (nth ast 2) 1)))
-      (true (list "clause" ast (list "atom" "true"))))))
-
-(define
-  pl-db-prepend!
-  (fn
-    (db clause)
-    (let
-      ((key (pl-clause-key clause)) (table (dict-get db :clauses)))
-      (cond
-        ((nil? (dict-get table key)) (dict-set! table key (list clause)))
-        (true (dict-set! table key (cons clause (dict-get table key))))))))
-
-(define
-  pl-list-without
-  (fn
-    (lst i)
-    (cond
-      ((empty? lst) (list))
-      ((= i 0) (rest lst))
-      (true (cons (first lst) (pl-list-without (rest lst) (- i 1)))))))
-
-(define
-  pl-solve-assertz!
-  (fn
-    (db term k)
-    (begin (pl-db-add! db (pl-build-clause (pl-rt-to-ast term))) (k))))
-
-(define
-  pl-solve-asserta!
-  (fn
-    (db term k)
-    (begin (pl-db-prepend! db (pl-build-clause (pl-rt-to-ast term))) (k))))
-
-(define
-  pl-solve-retract!
-  (fn
-    (db term trail k)
-    (let
-      ((head-runtime (cond ((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2)) (first (pl-args term))) (true term)))
-        (body-runtime
-          (cond
-            ((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2))
-              (nth (pl-args term) 1))
-            (true (list "atom" "true")))))
-      (let
-        ((wh (pl-walk head-runtime)))
-        (cond
-          ((pl-var? wh) false)
-          (true
-            (let
-              ((key (pl-head-key wh)))
-              (pl-retract-try-each
-                db
-                key
-                (pl-db-lookup db key)
-                head-runtime
-                body-runtime
-                0
-                trail
-                k))))))))
-
-(define
-  pl-deep-copy
-  (fn
-    (t var-map)
-    (let
-      ((w (pl-walk t)))
-      (cond
-        ((pl-var? w)
-          (let
-            ((id-key (str (pl-var-id w))))
-            (cond
-              ((dict-has? var-map id-key) (dict-get var-map id-key))
-              (true
-                (let
-                  ((nv (pl-mk-rt-var (dict-get w :name))))
-                  (begin (dict-set! var-map id-key nv) nv))))))
-        ((pl-compound? w)
-          (list
-            "compound"
-            (pl-fun w)
-            (map (fn (a) (pl-deep-copy a var-map)) (pl-args w))))
-        (true w)))))
-
-(define
-  pl-each-into-dict!
-  (fn
-    (terms d)
-    (cond
-      ((empty? terms) nil)
-      (true
-        (begin
-          (dict-set! d (pl-format-term (first terms)) (first terms))
-          (pl-each-into-dict! (rest terms) d))))))
-
-(define
-  pl-sort-uniq-terms
-  (fn
-    (terms)
-    (let
-      ((kv {}))
-      (begin
-        (pl-each-into-dict! terms kv)
-        (let
-          ((sorted-keys (sort (keys kv))))
-          (map (fn (k) (dict-get kv k)) sorted-keys))))))
-
-(define
-  pl-collect-solutions
-  (fn
-    (db template-rt goal-rt trail)
-    (let
-      ((box {:results (list)}) (mark (pl-trail-mark trail)))
-      (begin
-        (pl-solve!
-          db
-          goal-rt
-          trail
-          {:cut false}
-          (fn
-            ()
-            (begin
-              (append!
-                (dict-get box :results)
-                (pl-deep-copy template-rt {}))
-              false)))
-        (pl-trail-undo-to! trail mark)
-        (dict-get box :results)))))
-
-(define
-  pl-solve-findall!
-  (fn
-    (db template-rt goal-rt third-rt trail k)
-    (let
-      ((items (pl-collect-solutions db template-rt goal-rt trail)))
-      (let
-        ((rl (pl-mk-list-term items (pl-nil-term))))
-        (pl-solve-eq! third-rt rl trail k)))))
-
-(define
-  pl-solve-bagof!
-  (fn
-    (db template-rt goal-rt third-rt trail k)
-    (let
-      ((items (pl-collect-solutions db template-rt goal-rt trail)))
-      (cond
-        ((empty? items) false)
-        (true
-          (let
-            ((rl (pl-mk-list-term items (pl-nil-term))))
-            (pl-solve-eq! third-rt rl trail k)))))))
-
-(define
-  pl-solve-setof!
-  (fn
-    (db template-rt goal-rt third-rt trail k)
-    (let
-      ((items (pl-collect-solutions db template-rt goal-rt trail)))
-      (cond
-        ((empty? items) false)
-        (true
-          (let
-            ((sorted (pl-sort-uniq-terms items)))
-            (let
-              ((rl (pl-mk-list-term sorted (pl-nil-term))))
-              (pl-solve-eq! third-rt rl trail k))))))))
-
-(define
-  pl-solve-eq2!
-  (fn
-    (a1 b1 a2 b2 trail k)
-    (let
-      ((mark (pl-trail-mark trail)))
-      (cond
-        ((and (pl-unify! a1 b1 trail) (pl-unify! a2 b2 trail))
-          (let
-            ((r (k)))
-            (cond
-              (r true)
-              (true (begin (pl-trail-undo-to! trail mark) false)))))
-        (true (begin (pl-trail-undo-to! trail mark) false))))))
-
-(define
-  pl-make-fresh-args
-  (fn
-    (n)
-    (cond
-      ((<= n 0) (list))
-      (true (cons (pl-mk-rt-var "_") (pl-make-fresh-args (- n 1)))))))
-
-(define
-  pl-solve-functor-construct!
-  (fn
-    (term-rt name-rt arity-rt trail k)
-    (let
-      ((wn (pl-walk name-rt)) (wa (pl-walk arity-rt)))
-      (cond
-        ((and (pl-num? wa) (= (pl-num-val wa) 0))
-          (cond
-            ((or (pl-atom? wn) (pl-num? wn))
-              (pl-solve-eq! term-rt wn trail k))
-            (true false)))
-        ((and (pl-num? wa) (> (pl-num-val wa) 0) (pl-atom? wn))
-          (let
-            ((new-args (pl-make-fresh-args (pl-num-val wa))))
-            (pl-solve-eq!
-              term-rt
-              (list "compound" (pl-atom-name wn) new-args)
-              trail
-              k)))
-        (true false)))))
-
-(define
-  pl-solve-functor!
-  (fn
-    (term-rt name-rt arity-rt trail k)
-    (let
-      ((wt (pl-walk term-rt)))
-      (cond
-        ((pl-var? wt)
-          (pl-solve-functor-construct! term-rt name-rt arity-rt trail k))
-        ((pl-atom? wt)
-          (pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k))
-        ((pl-num? wt)
-          (pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k))
-        ((pl-compound? wt)
-          (pl-solve-eq2!
-            name-rt
-            (list "atom" (pl-fun wt))
-            arity-rt
-            (list "num" (len (pl-args wt)))
-            trail
-            k))
-        (true false)))))
-
-(define
-  pl-solve-arg!
-  (fn
-    (n-rt term-rt arg-rt trail k)
-    (let
-      ((wn (pl-walk n-rt)) (wt (pl-walk term-rt)))
-      (cond
-        ((and (pl-num? wn) (pl-compound? wt))
-          (let
-            ((idx (pl-num-val wn)) (args (pl-args wt)))
-            (cond
-              ((and (>= idx 1) (<= idx (len args)))
-                (pl-solve-eq! arg-rt (nth args (- idx 1)) trail k))
-              (true false))))
-        (true false)))))
-
-(define
-  pl-retract-try-each
-  (fn
-    (db key remaining head-rt body-rt idx trail k)
-    (cond
-      ((empty? remaining) false)
-      (true
-        (let
-          ((mark (pl-trail-mark trail))
-            (cl (pl-instantiate-fresh (first remaining))))
-          (cond
-            ((and (pl-unify! head-rt (nth cl 1) trail) (pl-unify! body-rt (nth cl 2) trail))
-              (begin
-                (let
-                  ((all (pl-db-lookup db key)))
-                  (dict-set!
-                    (dict-get db :clauses)
-                    key
-                    (pl-list-without all idx)))
-                (let
-                  ((r (k)))
-                  (cond
-                    (r true)
-                    (true (begin (pl-trail-undo-to! trail mark) false))))))
-            (true
-              (begin
-                (pl-trail-undo-to! trail mark)
-                (pl-retract-try-each
-                  db
-                  key
-                  (rest remaining)
-                  head-rt
-                  body-rt
-                  (+ idx 1)
-                  trail
-                  k)))))))))
-
-(define
-  pl-cut?
-  (fn (t) (and (list? t) (not (empty? t)) (= (first t) "cut"))))
-
-(define
-  pl-solve!
-  (fn
-    (db goal trail cut-box k)
-    (let
-      ((g (pl-walk goal)))
-      (cond
-        ((pl-var? g) false)
-        ((pl-cut? g) (begin (dict-set! cut-box :cut true) (k)))
-        ((and (pl-atom? g) (= (pl-atom-name g) "true")) (k))
-        ((and (pl-atom? g) (= (pl-atom-name g) "fail")) false)
-        ((and (pl-atom? g) (= (pl-atom-name g) "nl"))
-          (begin (pl-output-write! "\n") (k)))
-        ((and (pl-compound? g) (= (pl-fun g) "=") (= (len (pl-args g)) 2))
-          (pl-solve-eq! (first (pl-args g)) (nth (pl-args g) 1) trail k))
-        ((and (pl-compound? g) (= (pl-fun g) "\\=") (= (len (pl-args g)) 2))
-          (pl-solve-not-eq!
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            trail
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "is") (= (len (pl-args g)) 2))
-          (pl-solve-eq!
-            (first (pl-args g))
-            (list "num" (pl-eval-arith (nth (pl-args g) 1)))
-            trail
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "<") (= (len (pl-args g)) 2))
-          (cond
-            ((< (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
-              (k))
-            (true false)))
-        ((and (pl-compound? g) (= (pl-fun g) ">") (= (len (pl-args g)) 2))
-          (cond
-            ((> (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
-              (k))
-            (true false)))
-        ((and (pl-compound? g) (= (pl-fun g) "=<") (= (len (pl-args g)) 2))
-          (cond
-            ((<= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
-              (k))
-            (true false)))
-        ((and (pl-compound? g) (= (pl-fun g) ">=") (= (len (pl-args g)) 2))
-          (cond
-            ((>= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
-              (k))
-            (true false)))
-        ((and (pl-compound? g) (= (pl-fun g) ",") (= (len (pl-args g)) 2))
-          (pl-solve!
-            db
-            (first (pl-args g))
-            trail
-            cut-box
-            (fn () (pl-solve! db (nth (pl-args g) 1) trail cut-box k))))
-        ((and (pl-compound? g) (= (pl-fun g) ";") (= (len (pl-args g)) 2))
-          (pl-solve-or!
-            db
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            trail
-            cut-box
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "->") (= (len (pl-args g)) 2))
-          (pl-solve-if-then-else!
-            db
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            (list "atom" "fail")
-            trail
-            cut-box
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "call") (= (len (pl-args g)) 1))
-          (let
-            ((call-cb {:cut false}))
-            (pl-solve! db (first (pl-args g)) trail call-cb k)))
-        ((and (pl-compound? g) (= (pl-fun g) "write") (= (len (pl-args g)) 1))
-          (begin
-            (pl-output-write! (pl-format-term (first (pl-args g))))
-            (k)))
-        ((and (pl-compound? g) (= (pl-fun g) "assertz") (= (len (pl-args g)) 1))
-          (pl-solve-assertz! db (first (pl-args g)) k))
-        ((and (pl-compound? g) (= (pl-fun g) "assert") (= (len (pl-args g)) 1))
-          (pl-solve-assertz! db (first (pl-args g)) k))
-        ((and (pl-compound? g) (= (pl-fun g) "asserta") (= (len (pl-args g)) 1))
-          (pl-solve-asserta! db (first (pl-args g)) k))
-        ((and (pl-compound? g) (= (pl-fun g) "retract") (= (len (pl-args g)) 1))
-          (pl-solve-retract! db (first (pl-args g)) trail k))
-        ((and (pl-compound? g) (= (pl-fun g) "findall") (= (len (pl-args g)) 3))
-          (pl-solve-findall!
-            db
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            (nth (pl-args g) 2)
-            trail
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "bagof") (= (len (pl-args g)) 3))
-          (pl-solve-bagof!
-            db
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            (nth (pl-args g) 2)
-            trail
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "setof") (= (len (pl-args g)) 3))
-          (pl-solve-setof!
-            db
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            (nth (pl-args g) 2)
-            trail
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "copy_term") (= (len (pl-args g)) 2))
-          (pl-solve-eq!
-            (nth (pl-args g) 1)
-            (pl-deep-copy (first (pl-args g)) {})
-            trail
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "functor") (= (len (pl-args g)) 3))
-          (pl-solve-functor!
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            (nth (pl-args g) 2)
-            trail
-            k))
-        ((and (pl-compound? g) (= (pl-fun g) "arg") (= (len (pl-args g)) 3))
-          (pl-solve-arg!
-            (first (pl-args g))
-            (nth (pl-args g) 1)
-            (nth (pl-args g) 2)
-            trail
-            k))
-        (true (pl-solve-user! db g trail cut-box k))))))
-
-(define
-  pl-solve-or!
-  (fn
-    (db a b trail cut-box k)
-    (cond
-      ((and (pl-compound? a) (= (pl-fun a) "->") (= (len (pl-args a)) 2))
-        (pl-solve-if-then-else!
-          db
-          (first (pl-args a))
-          (nth (pl-args a) 1)
-          b
-          trail
-          cut-box
-          k))
-      (true
-        (let
-          ((mark (pl-trail-mark trail)))
-          (let
-            ((r (pl-solve! db a trail cut-box k)))
-            (cond
-              (r true)
-              ((dict-get cut-box :cut) false)
-              (true
-                (begin
-                  (pl-trail-undo-to! trail mark)
-                  (pl-solve! db b trail cut-box k))))))))))
-
-(define
-  pl-solve-if-then-else!
-  (fn
-    (db cond-goal then-goal else-goal trail cut-box k)
-    (let
-      ((mark (pl-trail-mark trail)))
-      (let
-        ((local-cb {:cut false}))
-        (let
-          ((found {:val false}))
-          (pl-solve!
-            db
-            cond-goal
-            trail
-            local-cb
-            (fn () (begin (dict-set! found :val true) true)))
-          (cond
-            ((dict-get found :val) (pl-solve! db then-goal trail cut-box k))
-            (true
-              (begin
-                (pl-trail-undo-to! trail mark)
-                (pl-solve! db else-goal trail cut-box k)))))))))
-
-(define pl-output-buffer "")
-
-(define pl-output-clear! (fn () (set! pl-output-buffer "")))
-
-(define
-  pl-output-write!
-  (fn (s) (begin (set! pl-output-buffer (str pl-output-buffer s)) nil)))
-
-(define
-  pl-format-args
-  (fn
-    (args)
-    (cond
-      ((empty? args) "")
-      ((= (len args) 1) (pl-format-term (first args)))
-      (true
-        (str
-          (pl-format-term (first args))
-          ", "
-          (pl-format-args (rest args)))))))
-
-(define
-  pl-format-term
-  (fn
-    (t)
-    (let
-      ((w (pl-walk-deep t)))
-      (cond
-        ((pl-var? w) (str "_" (pl-var-id w)))
-        ((pl-atom? w) (pl-atom-name w))
-        ((pl-num? w) (str (pl-num-val w)))
-        ((pl-str? w) (pl-str-val w))
-        ((pl-compound? w)
-          (str (pl-fun w) "(" (pl-format-args (pl-args w)) ")"))
-        (true (str w))))))
-
-(define
-  pl-eval-arith
-  (fn
-    (t)
-    (let
-      ((w (pl-walk-deep t)))
-      (cond
-        ((pl-num? w) (pl-num-val w))
-        ((pl-compound? w)
-          (let
-            ((f (pl-fun w)) (args (pl-args w)))
-            (cond
-              ((and (= f "+") (= (len args) 2))
-                (+
-                  (pl-eval-arith (first args))
-                  (pl-eval-arith (nth args 1))))
-              ((and (= f "-") (= (len args) 2))
-                (-
-                  (pl-eval-arith (first args))
-                  (pl-eval-arith (nth args 1))))
-              ((and (= f "-") (= (len args) 1))
-                (- 0 (pl-eval-arith (first args))))
-              ((and (= f "*") (= (len args) 2))
-                (*
-                  (pl-eval-arith (first args))
-                  (pl-eval-arith (nth args 1))))
-              ((and (= f "/") (= (len args) 2))
-                (/
-                  (pl-eval-arith (first args))
-                  (pl-eval-arith (nth args 1))))
-              ((and (= f "mod") (= (len args) 2))
-                (mod
-                  (pl-eval-arith (first args))
-                  (pl-eval-arith (nth args 1))))
-              ((and (= f "abs") (= (len args) 1))
-                (let
-                  ((v (pl-eval-arith (first args))))
-                  (cond ((< v 0) (- 0 v)) (true v))))
-              (true 0))))
-        (true 0)))))
-
-(define
-  pl-solve-not-eq!
-  (fn
-    (a b trail k)
-    (let
-      ((mark (pl-trail-mark trail)))
-      (let
-        ((unified (pl-unify! a b trail)))
-        (begin
-          (pl-trail-undo-to! trail mark)
-          (cond (unified false) (true (k))))))))
-
-(define
-  pl-solve-eq!
-  (fn
-    (a b trail k)
-    (let
-      ((mark (pl-trail-mark trail)))
-      (cond
-        ((pl-unify! a b trail)
-          (let
-            ((r (k)))
-            (cond
-              (r true)
-              (true (begin (pl-trail-undo-to! trail mark) false)))))
-        (true (begin (pl-trail-undo-to! trail mark) false))))))
-
-(define
-  pl-solve-user!
-  (fn
-    (db goal trail outer-cut-box k)
-    (let
-      ((inner-cut-box {:cut false}))
-      (let
-        ((outer-was-cut (dict-get outer-cut-box :cut)))
-        (pl-try-clauses!
-          db
-          goal
-          trail
-          (pl-db-lookup-goal db goal)
-          outer-cut-box
-          outer-was-cut
-          inner-cut-box
-          k)))))
-
-(define
-  pl-try-clauses!
-  (fn
-    (db goal trail clauses outer-cut-box outer-was-cut inner-cut-box k)
-    (cond
-      ((empty? clauses) false)
-      (true
-        (let
-          ((mark (pl-trail-mark trail)))
-          (let
-            ((clause (pl-instantiate-fresh (first clauses))))
-            (let
-              ((head (nth clause 1)) (body (nth clause 2)))
-              (cond
-                ((pl-unify! goal head trail)
-                  (let
-                    ((r (pl-solve! db body trail inner-cut-box k)))
-                    (cond
-                      (r true)
-                      ((dict-get inner-cut-box :cut)
-                        (begin (pl-trail-undo-to! trail mark) false))
-                      ((and (not outer-was-cut) (dict-get outer-cut-box :cut))
-                        (begin (pl-trail-undo-to! trail mark) false))
-                      (true
-                        (begin
-                          (pl-trail-undo-to! trail mark)
-                          (pl-try-clauses!
-                            db
-                            goal
-                            trail
-                            (rest clauses)
-                            outer-cut-box
-                            outer-was-cut
-                            inner-cut-box
-                            k))))))
-                (true
-                  (begin
-                    (pl-trail-undo-to! trail mark)
-                    (pl-try-clauses!
-                      db
-                      goal
-                      trail
-                      (rest clauses)
-                      outer-cut-box
-                      outer-was-cut
-                      inner-cut-box
-                      k)))))))))))
-
-(define
-  pl-solve-once!
-  (fn (db goal trail) (pl-solve! db goal trail {:cut false} (fn () true))))
-
-(define
-  pl-solve-count!
-  (fn
-    (db goal trail)
-    (let
-      ((box {:n 0}))
-      (pl-solve!
-        db
-        goal
-        trail
-        {:cut false}
-        (fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
-      (dict-get box :n))))

lib/prolog/scoreboard.json

@@ -1,7 +0,0 @@
-{
-  "total_passed": 238,
-  "total_failed": 0,
-  "total": 238,
-  "suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"term_inspect":{"passed":14,"total":14,"failed":0},"append":{"passed":6,"total":6,"failed":0},"reverse":{"passed":6,"total":6,"failed":0},"member":{"passed":7,"total":7,"failed":0},"nqueens":{"passed":6,"total":6,"failed":0},"family":{"passed":10,"total":10,"failed":0}},
-  "generated": "2026-04-25T08:39:07+00:00"
-}

lib/prolog/scoreboard.md

@@ -1,23 +0,0 @@
-# Prolog scoreboard
-
-**238 / 238 passing** (0 failure(s)).
-Generated 2026-04-25T08:39:07+00:00.
-
-| Suite | Passed | Total | Status |
-|-------|--------|-------|--------|
-| parse | 25 | 25 | ok |
-| unify | 47 | 47 | ok |
-| clausedb | 14 | 14 | ok |
-| solve | 62 | 62 | ok |
-| operators | 19 | 19 | ok |
-| dynamic | 11 | 11 | ok |
-| findall | 11 | 11 | ok |
-| term_inspect | 14 | 14 | ok |
-| append | 6 | 6 | ok |
-| reverse | 6 | 6 | ok |
-| member | 7 | 7 | ok |
-| nqueens | 6 | 6 | ok |
-| family | 10 | 10 | ok |
-
-Run `bash lib/prolog/conformance.sh` to refresh. Override the binary
-with `SX_SERVER=path/to/sx_server.exe bash …`.

lib/prolog/tests/clausedb.sx

@@ -1,99 +0,0 @@
-;; lib/prolog/tests/clausedb.sx — Clause DB unit tests
-
-(define pl-db-test-count 0)
-(define pl-db-test-pass 0)
-(define pl-db-test-fail 0)
-(define pl-db-test-failures (list))
-
-(define
-  pl-db-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-db-test-count (+ pl-db-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-db-test-pass (+ pl-db-test-pass 1))
-        (begin
-          (set! pl-db-test-fail (+ pl-db-test-fail 1))
-          (append!
-            pl-db-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(pl-db-test!
-  "head-key atom arity 0"
-  (pl-head-key (nth (first (pl-parse "foo.")) 1))
-  "foo/0")
-
-(pl-db-test!
-  "head-key compound arity 2"
-  (pl-head-key (nth (first (pl-parse "bar(a, b).")) 1))
-  "bar/2")
-
-(pl-db-test!
-  "clause-key of :- clause"
-  (pl-clause-key (first (pl-parse "likes(mary, X) :- friendly(X).")))
-  "likes/2")
-
-(pl-db-test!
-  "empty db lookup returns empty list"
-  (len (pl-db-lookup (pl-mk-db) "parent/2"))
-  0)
-
-(define pl-db-t1 (pl-mk-db))
-(pl-db-load! pl-db-t1 (pl-parse "foo(a). foo(b). foo(c)."))
-
-(pl-db-test!
-  "three facts same functor"
-  (len (pl-db-lookup pl-db-t1 "foo/1"))
-  3)
-(pl-db-test!
-  "mismatching key returns empty"
-  (len (pl-db-lookup pl-db-t1 "foo/2"))
-  0)
-
-(pl-db-test!
-  "first clause has arg a"
-  (pl-atom-name
-    (first (pl-args (nth (first (pl-db-lookup pl-db-t1 "foo/1")) 1))))
-  "a")
-
-(pl-db-test!
-  "third clause has arg c"
-  (pl-atom-name
-    (first (pl-args (nth (nth (pl-db-lookup pl-db-t1 "foo/1") 2) 1))))
-  "c")
-
-(define pl-db-t2 (pl-mk-db))
-(pl-db-load! pl-db-t2 (pl-parse "foo. bar. foo. parent(a, b). parent(c, d)."))
-
-(pl-db-test!
-  "atom heads keyed as foo/0"
-  (len (pl-db-lookup pl-db-t2 "foo/0"))
-  2)
-(pl-db-test!
-  "atom heads keyed as bar/0"
-  (len (pl-db-lookup pl-db-t2 "bar/0"))
-  1)
-(pl-db-test!
-  "compound heads keyed as parent/2"
-  (len (pl-db-lookup pl-db-t2 "parent/2"))
-  2)
-
-(pl-db-test!
-  "lookup-goal extracts functor/arity"
-  (len
-    (pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "parent(X, Y).")) 1)))
-  2)
-
-(pl-db-test!
-  "lookup-goal on atom goal"
-  (len (pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "foo.")) 1)))
-  2)
-
-(pl-db-test!
-  "stored clause is clause form"
-  (first (first (pl-db-lookup pl-db-t2 "parent/2")))
-  "clause")
-
-(define pl-clausedb-tests-run! (fn () {:failed pl-db-test-fail :passed pl-db-test-pass :total pl-db-test-count :failures pl-db-test-failures}))

lib/prolog/tests/dynamic.sx

@@ -1,158 +0,0 @@
-;; lib/prolog/tests/dynamic.sx — assert/asserta/assertz/retract.
-
-(define pl-dy-test-count 0)
-(define pl-dy-test-pass 0)
-(define pl-dy-test-fail 0)
-(define pl-dy-test-failures (list))
-
-(define
-  pl-dy-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-dy-test-count (+ pl-dy-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-dy-test-pass (+ pl-dy-test-pass 1))
-        (begin
-          (set! pl-dy-test-fail (+ pl-dy-test-fail 1))
-          (append!
-            pl-dy-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-dy-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-;; assertz then query
-(define pl-dy-db1 (pl-mk-db))
-(pl-solve-once!
-  pl-dy-db1
-  (pl-dy-goal "assertz(foo(1))" {})
-  (pl-mk-trail))
-(pl-dy-test!
-  "assertz(foo(1)) + foo(1)"
-  (pl-solve-once! pl-dy-db1 (pl-dy-goal "foo(1)" {}) (pl-mk-trail))
-  true)
-
-(pl-dy-test!
-  "after one assertz, foo/1 has 1 clause"
-  (pl-solve-count! pl-dy-db1 (pl-dy-goal "foo(X)" {}) (pl-mk-trail))
-  1)
-
-;; assertz appends — order preserved
-(define pl-dy-db2 (pl-mk-db))
-(pl-solve-once!
-  pl-dy-db2
-  (pl-dy-goal "assertz(p(1))" {})
-  (pl-mk-trail))
-(pl-solve-once!
-  pl-dy-db2
-  (pl-dy-goal "assertz(p(2))" {})
-  (pl-mk-trail))
-(pl-dy-test!
-  "assertz twice — count 2"
-  (pl-solve-count! pl-dy-db2 (pl-dy-goal "p(X)" {}) (pl-mk-trail))
-  2)
-
-(define pl-dy-env-a {})
-(pl-solve-once! pl-dy-db2 (pl-dy-goal "p(X)" pl-dy-env-a) (pl-mk-trail))
-(pl-dy-test!
-  "assertz: first solution is the first asserted (1)"
-  (pl-num-val (pl-walk-deep (dict-get pl-dy-env-a "X")))
-  1)
-
-;; asserta prepends
-(define pl-dy-db3 (pl-mk-db))
-(pl-solve-once!
-  pl-dy-db3
-  (pl-dy-goal "assertz(p(1))" {})
-  (pl-mk-trail))
-(pl-solve-once!
-  pl-dy-db3
-  (pl-dy-goal "asserta(p(99))" {})
-  (pl-mk-trail))
-(define pl-dy-env-b {})
-(pl-solve-once! pl-dy-db3 (pl-dy-goal "p(X)" pl-dy-env-b) (pl-mk-trail))
-(pl-dy-test!
-  "asserta: prepended clause is first solution"
-  (pl-num-val (pl-walk-deep (dict-get pl-dy-env-b "X")))
-  99)
-
-;; assert/1 = assertz/1
-(define pl-dy-db4 (pl-mk-db))
-(pl-solve-once!
-  pl-dy-db4
-  (pl-dy-goal "assert(g(7))" {})
-  (pl-mk-trail))
-(pl-dy-test!
-  "assert/1 alias"
-  (pl-solve-once! pl-dy-db4 (pl-dy-goal "g(7)" {}) (pl-mk-trail))
-  true)
-
-;; retract removes a fact
-(define pl-dy-db5 (pl-mk-db))
-(pl-solve-once!
-  pl-dy-db5
-  (pl-dy-goal "assertz(q(1))" {})
-  (pl-mk-trail))
-(pl-solve-once!
-  pl-dy-db5
-  (pl-dy-goal "assertz(q(2))" {})
-  (pl-mk-trail))
-(pl-solve-once!
-  pl-dy-db5
-  (pl-dy-goal "assertz(q(3))" {})
-  (pl-mk-trail))
-(pl-dy-test!
-  "before retract: 3 clauses"
-  (pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail))
-  3)
-(pl-solve-once!
-  pl-dy-db5
-  (pl-dy-goal "retract(q(2))" {})
-  (pl-mk-trail))
-(pl-dy-test!
-  "after retract(q(2)): 2 clauses left"
-  (pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail))
-  2)
-
-(define pl-dy-env-c {})
-(pl-solve-once! pl-dy-db5 (pl-dy-goal "q(X)" pl-dy-env-c) (pl-mk-trail))
-(pl-dy-test!
-  "after retract(q(2)): first remaining is 1"
-  (pl-num-val (pl-walk-deep (dict-get pl-dy-env-c "X")))
-  1)
-
-;; retract of non-existent
-(pl-dy-test!
-  "retract(missing(0)) on empty db fails"
-  (pl-solve-once!
-    (pl-mk-db)
-    (pl-dy-goal "retract(missing(0))" {})
-    (pl-mk-trail))
-  false)
-
-;; retract with unbound var matches first
-(define pl-dy-db6 (pl-mk-db))
-(pl-solve-once!
-  pl-dy-db6
-  (pl-dy-goal "assertz(r(11))" {})
-  (pl-mk-trail))
-(pl-solve-once!
-  pl-dy-db6
-  (pl-dy-goal "assertz(r(22))" {})
-  (pl-mk-trail))
-(define pl-dy-env-d {})
-(pl-solve-once!
-  pl-dy-db6
-  (pl-dy-goal "retract(r(X))" pl-dy-env-d)
-  (pl-mk-trail))
-(pl-dy-test!
-  "retract(r(X)) binds X to first match"
-  (pl-num-val (pl-walk-deep (dict-get pl-dy-env-d "X")))
-  11)
-
-(define pl-dynamic-tests-run! (fn () {:failed pl-dy-test-fail :passed pl-dy-test-pass :total pl-dy-test-count :failures pl-dy-test-failures}))

lib/prolog/tests/findall.sx

@@ -1,167 +0,0 @@
-;; lib/prolog/tests/findall.sx — findall/3, bagof/3, setof/3.
-
-(define pl-fb-test-count 0)
-(define pl-fb-test-pass 0)
-(define pl-fb-test-fail 0)
-(define pl-fb-test-failures (list))
-
-(define
-  pl-fb-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-fb-test-count (+ pl-fb-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-fb-test-pass (+ pl-fb-test-pass 1))
-        (begin
-          (set! pl-fb-test-fail (+ pl-fb-test-fail 1))
-          (append!
-            pl-fb-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-fb-term-to-sx
-  (fn
-    (t)
-    (cond
-      ((pl-num? t) (pl-num-val t))
-      ((pl-atom? t) (pl-atom-name t))
-      (true (list :complex)))))
-
-(define
-  pl-fb-list-walked
-  (fn
-    (w)
-    (cond
-      ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
-      ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
-        (cons
-          (pl-fb-term-to-sx (first (pl-args w)))
-          (pl-fb-list-walked (nth (pl-args w) 1))))
-      (true (list :not-list)))))
-
-(define pl-fb-list-to-sx (fn (t) (pl-fb-list-walked (pl-walk-deep t))))
-
-(define
-  pl-fb-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define pl-fb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
-
-(define pl-fb-db (pl-mk-db))
-(pl-db-load! pl-fb-db (pl-parse pl-fb-prog-src))
-
-;; ── findall ──
-
-(define pl-fb-env-1 {})
-(pl-solve-once!
-  pl-fb-db
-  (pl-fb-goal "findall(X, member(X, [a, b, c]), L)" pl-fb-env-1)
-  (pl-mk-trail))
-(pl-fb-test!
-  "findall member [a, b, c]"
-  (pl-fb-list-to-sx (dict-get pl-fb-env-1 "L"))
-  (list "a" "b" "c"))
-
-(define pl-fb-env-2 {})
-(pl-solve-once!
-  pl-fb-db
-  (pl-fb-goal "findall(X, (member(X, [1, 2, 3]), X >= 2), L)" pl-fb-env-2)
-  (pl-mk-trail))
-(pl-fb-test!
-  "findall with comparison filter"
-  (pl-fb-list-to-sx (dict-get pl-fb-env-2 "L"))
-  (list 2 3))
-
-(define pl-fb-env-3 {})
-(pl-solve-once!
-  pl-fb-db
-  (pl-fb-goal "findall(X, fail, L)" pl-fb-env-3)
-  (pl-mk-trail))
-(pl-fb-test!
-  "findall on fail succeeds with empty list"
-  (pl-fb-list-to-sx (dict-get pl-fb-env-3 "L"))
-  (list))
-
-(pl-fb-test!
-  "findall(X, fail, L) the goal succeeds"
-  (pl-solve-once!
-    pl-fb-db
-    (pl-fb-goal "findall(X, fail, L)" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-fb-env-4 {})
-(pl-solve-once!
-  pl-fb-db
-  (pl-fb-goal
-    "findall(p(X, Y), (member(X, [1, 2]), member(Y, [a, b])), L)"
-    pl-fb-env-4)
-  (pl-mk-trail))
-(pl-fb-test!
-  "findall over compound template — count = 4"
-  (len (pl-fb-list-to-sx (dict-get pl-fb-env-4 "L")))
-  4)
-
-;; ── bagof ──
-
-(pl-fb-test!
-  "bagof succeeds when results exist"
-  (pl-solve-once!
-    pl-fb-db
-    (pl-fb-goal "bagof(X, member(X, [1, 2, 3]), L)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-fb-test!
-  "bagof fails on empty"
-  (pl-solve-once!
-    pl-fb-db
-    (pl-fb-goal "bagof(X, fail, L)" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-fb-env-5 {})
-(pl-solve-once!
-  pl-fb-db
-  (pl-fb-goal "bagof(X, member(X, [c, a, b]), L)" pl-fb-env-5)
-  (pl-mk-trail))
-(pl-fb-test!
-  "bagof preserves order"
-  (pl-fb-list-to-sx (dict-get pl-fb-env-5 "L"))
-  (list "c" "a" "b"))
-
-;; ── setof ──
-
-(define pl-fb-env-6 {})
-(pl-solve-once!
-  pl-fb-db
-  (pl-fb-goal "setof(X, member(X, [c, a, b, a, c]), L)" pl-fb-env-6)
-  (pl-mk-trail))
-(pl-fb-test!
-  "setof sorts + dedupes atoms"
-  (pl-fb-list-to-sx (dict-get pl-fb-env-6 "L"))
-  (list "a" "b" "c"))
-
-(pl-fb-test!
-  "setof fails on empty"
-  (pl-solve-once!
-    pl-fb-db
-    (pl-fb-goal "setof(X, fail, L)" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-fb-env-7 {})
-(pl-solve-once!
-  pl-fb-db
-  (pl-fb-goal "setof(X, member(X, [3, 1, 2, 1, 3]), L)" pl-fb-env-7)
-  (pl-mk-trail))
-(pl-fb-test!
-  "setof sorts + dedupes nums"
-  (pl-fb-list-to-sx (dict-get pl-fb-env-7 "L"))
-  (list 1 2 3))
-
-(define pl-findall-tests-run! (fn () {:failed pl-fb-test-fail :passed pl-fb-test-pass :total pl-fb-test-count :failures pl-fb-test-failures}))

lib/prolog/tests/operators.sx

@@ -1,193 +0,0 @@
-;; lib/prolog/tests/operators.sx — operator-table parsing + comparison built-ins.
-
-(define pl-op-test-count 0)
-(define pl-op-test-pass 0)
-(define pl-op-test-fail 0)
-(define pl-op-test-failures (list))
-
-(define
-  pl-op-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-op-test-count (+ pl-op-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-op-test-pass (+ pl-op-test-pass 1))
-        (begin
-          (set! pl-op-test-fail (+ pl-op-test-fail 1))
-          (append!
-            pl-op-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define pl-op-empty-db (pl-mk-db))
-
-(define
-  pl-op-body
-  (fn (src) (nth (first (pl-parse (str "g :- " src "."))) 2)))
-
-(define pl-op-goal (fn (src env) (pl-instantiate (pl-op-body src) env)))
-
-;; ── parsing tests ──
-
-(pl-op-test!
-  "infix +"
-  (pl-op-body "a + b")
-  (list "compound" "+" (list (list "atom" "a") (list "atom" "b"))))
-
-(pl-op-test!
-  "infix * tighter than +"
-  (pl-op-body "a + b * c")
-  (list
-    "compound"
-    "+"
-    (list
-      (list "atom" "a")
-      (list "compound" "*" (list (list "atom" "b") (list "atom" "c"))))))
-
-(pl-op-test!
-  "parens override precedence"
-  (pl-op-body "(a + b) * c")
-  (list
-    "compound"
-    "*"
-    (list
-      (list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
-      (list "atom" "c"))))
-
-(pl-op-test!
-  "+ is yfx (left-assoc)"
-  (pl-op-body "a + b + c")
-  (list
-    "compound"
-    "+"
-    (list
-      (list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
-      (list "atom" "c"))))
-
-(pl-op-test!
-  "; is xfy (right-assoc)"
-  (pl-op-body "a ; b ; c")
-  (list
-    "compound"
-    ";"
-    (list
-      (list "atom" "a")
-      (list "compound" ";" (list (list "atom" "b") (list "atom" "c"))))))
-
-(pl-op-test!
-  "= folds at 700"
-  (pl-op-body "X = 5")
-  (list "compound" "=" (list (list "var" "X") (list "num" 5))))
-
-(pl-op-test!
-  "is + nests via 700>500>400"
-  (pl-op-body "X is 2 + 3 * 4")
-  (list
-    "compound"
-    "is"
-    (list
-      (list "var" "X")
-      (list
-        "compound"
-        "+"
-        (list
-          (list "num" 2)
-          (list "compound" "*" (list (list "num" 3) (list "num" 4))))))))
-
-(pl-op-test!
-  "< parses at 700"
-  (pl-op-body "2 < 3")
-  (list "compound" "<" (list (list "num" 2) (list "num" 3))))
-
-(pl-op-test!
-  "mod parses as yfx 400"
-  (pl-op-body "10 mod 3")
-  (list "compound" "mod" (list (list "num" 10) (list "num" 3))))
-
-(pl-op-test!
-  "comma in body folds right-assoc"
-  (pl-op-body "a, b, c")
-  (list
-    "compound"
-    ","
-    (list
-      (list "atom" "a")
-      (list "compound" "," (list (list "atom" "b") (list "atom" "c"))))))
-
-;; ── solver tests via infix ──
-
-(pl-op-test!
-  "X is 2 + 3 binds X = 5"
-  (let
-    ((env {}) (trail (pl-mk-trail)))
-    (begin
-      (pl-solve-once! pl-op-empty-db (pl-op-goal "X is 2 + 3" env) trail)
-      (pl-num-val (pl-walk-deep (dict-get env "X")))))
-  5)
-
-(pl-op-test!
-  "infix conjunction parses + solves"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "X = 5, X = 5" {})
-    (pl-mk-trail))
-  true)
-
-(pl-op-test!
-  "infix mismatch fails"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "X = 5, X = 6" {})
-    (pl-mk-trail))
-  false)
-
-(pl-op-test!
-  "infix disjunction picks left"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "true ; fail" {})
-    (pl-mk-trail))
-  true)
-
-(pl-op-test!
-  "2 < 5 succeeds"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "2 < 5" {})
-    (pl-mk-trail))
-  true)
-
-(pl-op-test!
-  "5 < 2 fails"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "5 < 2" {})
-    (pl-mk-trail))
-  false)
-
-(pl-op-test!
-  "5 >= 5 succeeds"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "5 >= 5" {})
-    (pl-mk-trail))
-  true)
-
-(pl-op-test!
-  "3 =< 5 succeeds"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "3 =< 5" {})
-    (pl-mk-trail))
-  true)
-
-(pl-op-test!
-  "infix < with arithmetic both sides"
-  (pl-solve-once!
-    pl-op-empty-db
-    (pl-op-goal "1 + 2 < 2 * 3" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-operators-tests-run! (fn () {:failed pl-op-test-fail :passed pl-op-test-pass :total pl-op-test-count :failures pl-op-test-failures}))

lib/prolog/tests/programs/append.pl

@@ -1,5 +0,0 @@
-%% append/3 — list concatenation, classic Prolog
-%% Two clauses: empty-prefix base case + recursive cons-prefix.
-%% Bidirectional — works in all modes: build, check, split.
-append([], L, L).
-append([H|T], L, [H|R]) :- append(T, L, R).

lib/prolog/tests/programs/append.sx

@@ -1,114 +0,0 @@
-;; lib/prolog/tests/programs/append.sx — append/3 test runner
-;;
-;; Mirrors the Prolog source in append.pl (embedded as a string here because
-;; the SX runtime has no file-read primitive yet).
-
-(define pl-ap-test-count 0)
-(define pl-ap-test-pass 0)
-(define pl-ap-test-fail 0)
-(define pl-ap-test-failures (list))
-
-(define
-  pl-ap-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-ap-test-count (+ pl-ap-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-ap-test-pass (+ pl-ap-test-pass 1))
-        (begin
-          (set! pl-ap-test-fail (+ pl-ap-test-fail 1))
-          (append!
-            pl-ap-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-ap-term-to-sx
-  (fn
-    (t)
-    (cond
-      ((pl-num? t) (pl-num-val t))
-      ((pl-atom? t) (pl-atom-name t))
-      (true (list :complex)))))
-
-(define
-  pl-ap-list-walked
-  (fn
-    (w)
-    (cond
-      ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
-      ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
-        (cons
-          (pl-ap-term-to-sx (first (pl-args w)))
-          (pl-ap-list-walked (nth (pl-args w) 1))))
-      (true (list :not-list)))))
-
-(define pl-ap-list-to-sx (fn (t) (pl-ap-list-walked (pl-walk-deep t))))
-
-(define
-  pl-ap-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define
-  pl-ap-prog-src
-  "append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
-
-(define pl-ap-db (pl-mk-db))
-
-(pl-db-load! pl-ap-db (pl-parse pl-ap-prog-src))
-
-(define pl-ap-env-1 {})
-(define pl-ap-goal-1 (pl-ap-goal "append([], [a, b], X)" pl-ap-env-1))
-(pl-solve-once! pl-ap-db pl-ap-goal-1 (pl-mk-trail))
-
-(pl-ap-test!
-  "append([], [a, b], X) → X = [a, b]"
-  (pl-ap-list-to-sx (dict-get pl-ap-env-1 "X"))
-  (list "a" "b"))
-
-(define pl-ap-env-2 {})
-(define pl-ap-goal-2 (pl-ap-goal "append([1, 2], [3, 4], X)" pl-ap-env-2))
-(pl-solve-once! pl-ap-db pl-ap-goal-2 (pl-mk-trail))
-
-(pl-ap-test!
-  "append([1, 2], [3, 4], X) → X = [1, 2, 3, 4]"
-  (pl-ap-list-to-sx (dict-get pl-ap-env-2 "X"))
-  (list 1 2 3 4))
-
-(pl-ap-test!
-  "append([1], [2, 3], [1, 2, 3]) succeeds"
-  (pl-solve-once!
-    pl-ap-db
-    (pl-ap-goal "append([1], [2, 3], [1, 2, 3])" {})
-    (pl-mk-trail))
-  true)
-
-(pl-ap-test!
-  "append([1, 2], [3], [1, 2, 4]) fails"
-  (pl-solve-once!
-    pl-ap-db
-    (pl-ap-goal "append([1, 2], [3], [1, 2, 4])" {})
-    (pl-mk-trail))
-  false)
-
-(pl-ap-test!
-  "append(X, Y, [1, 2, 3]) backtracks 4 times"
-  (pl-solve-count!
-    pl-ap-db
-    (pl-ap-goal "append(X, Y, [1, 2, 3])" {})
-    (pl-mk-trail))
-  4)
-
-(define pl-ap-env-6 {})
-(define pl-ap-goal-6 (pl-ap-goal "append(X, [3], [1, 2, 3])" pl-ap-env-6))
-(pl-solve-once! pl-ap-db pl-ap-goal-6 (pl-mk-trail))
-
-(pl-ap-test!
-  "append(X, [3], [1, 2, 3]) deduces X = [1, 2]"
-  (pl-ap-list-to-sx (dict-get pl-ap-env-6 "X"))
-  (list 1 2))
-
-(define pl-append-tests-run! (fn () {:failed pl-ap-test-fail :passed pl-ap-test-pass :total pl-ap-test-count :failures pl-ap-test-failures}))

lib/prolog/tests/programs/family.pl

@@ -1,24 +0,0 @@
-%% family — facts + transitive ancestor + derived relations.
-%% Five-generation tree: tom -> bob -> {ann, pat} -> jim, plus tom's
-%% other child liz.
-
-parent(tom, bob).
-parent(tom, liz).
-parent(bob, ann).
-parent(bob, pat).
-parent(pat, jim).
-
-male(tom).
-male(bob).
-male(jim).
-male(pat).
-female(liz).
-female(ann).
-
-father(F, C) :- parent(F, C), male(F).
-mother(M, C) :- parent(M, C), female(M).
-
-ancestor(X, Y) :- parent(X, Y).
-ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y).
-
-sibling(X, Y) :- parent(P, X), parent(P, Y), \=(X, Y).

lib/prolog/tests/programs/family.sx

@@ -1,116 +0,0 @@
-;; lib/prolog/tests/programs/family.sx — facts + ancestor + sibling relations.
-
-(define pl-fa-test-count 0)
-(define pl-fa-test-pass 0)
-(define pl-fa-test-fail 0)
-(define pl-fa-test-failures (list))
-
-(define
-  pl-fa-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-fa-test-count (+ pl-fa-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-fa-test-pass (+ pl-fa-test-pass 1))
-        (begin
-          (set! pl-fa-test-fail (+ pl-fa-test-fail 1))
-          (append!
-            pl-fa-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-fa-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define
-  pl-fa-prog-src
-  "parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(bob, pat). parent(pat, jim). male(tom). male(bob). male(jim). male(pat). female(liz). female(ann). father(F, C) :- parent(F, C), male(F). mother(M, C) :- parent(M, C), female(M). ancestor(X, Y) :- parent(X, Y). ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y). sibling(X, Y) :- parent(P, X), parent(P, Y), \\=(X, Y).")
-
-(define pl-fa-db (pl-mk-db))
-(pl-db-load! pl-fa-db (pl-parse pl-fa-prog-src))
-
-(pl-fa-test!
-  "parent(tom, bob) is a fact"
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "parent(tom, bob)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-fa-test!
-  "parent(tom, ann) — not a direct parent"
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "parent(tom, ann)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-fa-test!
-  "5 parent/2 facts in total"
-  (pl-solve-count!
-    pl-fa-db
-    (pl-fa-goal "parent(X, Y)" {})
-    (pl-mk-trail))
-  5)
-
-(pl-fa-test!
-  "ancestor(tom, jim) — three-step transitive"
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "ancestor(tom, jim)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-fa-test!
-  "tom has 5 ancestors-of: bob, liz, ann, pat, jim"
-  (pl-solve-count!
-    pl-fa-db
-    (pl-fa-goal "ancestor(tom, X)" {})
-    (pl-mk-trail))
-  5)
-
-(pl-fa-test!
-  "father(bob, ann) succeeds"
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "father(bob, ann)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-fa-test!
-  "father(liz, ann) fails (liz is female)"
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "father(liz, ann)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-fa-test!
-  "mother(liz, X) fails (liz has no children)"
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "mother(liz, X)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-fa-test!
-  "sibling(ann, pat) succeeds"
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "sibling(ann, pat)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-fa-test!
-  "sibling(ann, ann) fails by \\="
-  (pl-solve-once!
-    pl-fa-db
-    (pl-fa-goal "sibling(ann, ann)" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-family-tests-run! (fn () {:failed pl-fa-test-fail :passed pl-fa-test-pass :total pl-fa-test-count :failures pl-fa-test-failures}))

lib/prolog/tests/programs/member.pl

@@ -1,4 +0,0 @@
-%% member/2 — list membership.
-%% Generates all solutions on backtracking when the element is unbound.
-member(X, [X|_]).
-member(X, [_|T]) :- member(X, T).

lib/prolog/tests/programs/member.sx

@@ -1,91 +0,0 @@
-;; lib/prolog/tests/programs/member.sx — member/2 generator.
-
-(define pl-mb-test-count 0)
-(define pl-mb-test-pass 0)
-(define pl-mb-test-fail 0)
-(define pl-mb-test-failures (list))
-
-(define
-  pl-mb-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-mb-test-count (+ pl-mb-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-mb-test-pass (+ pl-mb-test-pass 1))
-        (begin
-          (set! pl-mb-test-fail (+ pl-mb-test-fail 1))
-          (append!
-            pl-mb-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-mb-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define pl-mb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
-
-(define pl-mb-db (pl-mk-db))
-(pl-db-load! pl-mb-db (pl-parse pl-mb-prog-src))
-
-(pl-mb-test!
-  "member(2, [1, 2, 3]) succeeds"
-  (pl-solve-once!
-    pl-mb-db
-    (pl-mb-goal "member(2, [1, 2, 3])" {})
-    (pl-mk-trail))
-  true)
-
-(pl-mb-test!
-  "member(4, [1, 2, 3]) fails"
-  (pl-solve-once!
-    pl-mb-db
-    (pl-mb-goal "member(4, [1, 2, 3])" {})
-    (pl-mk-trail))
-  false)
-
-(pl-mb-test!
-  "member(X, []) fails"
-  (pl-solve-once!
-    pl-mb-db
-    (pl-mb-goal "member(X, [])" {})
-    (pl-mk-trail))
-  false)
-
-(pl-mb-test!
-  "member(X, [a, b, c]) generates 3 solutions"
-  (pl-solve-count!
-    pl-mb-db
-    (pl-mb-goal "member(X, [a, b, c])" {})
-    (pl-mk-trail))
-  3)
-
-(define pl-mb-env-1 {})
-(define pl-mb-goal-1 (pl-mb-goal "member(X, [11, 22, 33])" pl-mb-env-1))
-(pl-solve-once! pl-mb-db pl-mb-goal-1 (pl-mk-trail))
-
-(pl-mb-test!
-  "member(X, [11, 22, 33]) first solution X = 11"
-  (pl-num-val (pl-walk-deep (dict-get pl-mb-env-1 "X")))
-  11)
-
-(pl-mb-test!
-  "member(2, [1, 2, 3, 2, 1]) matches twice on backtrack"
-  (pl-solve-count!
-    pl-mb-db
-    (pl-mb-goal "member(2, [1, 2, 3, 2, 1])" {})
-    (pl-mk-trail))
-  2)
-
-(pl-mb-test!
-  "member with unbound list cell unifies"
-  (pl-solve-once!
-    pl-mb-db
-    (pl-mb-goal "member(a, [X, b, c])" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-member-tests-run! (fn () {:failed pl-mb-test-fail :passed pl-mb-test-pass :total pl-mb-test-count :failures pl-mb-test-failures}))

lib/prolog/tests/programs/nqueens.pl

@@ -1,27 +0,0 @@
-%% nqueens — permutation-and-test formulation.
-%% Caller passes the row list [1..N]; queens/2 finds N column placements
-%% s.t. no two queens attack on a diagonal. Same-column attacks are
-%% structurally impossible — Qs is a permutation, all distinct.
-%%
-%% No `>/2` `</2` `=</2` built-ins yet, so range/3 is omitted; tests pass
-%; the literal range list. Once the operator table lands and arithmetic
-%% comparison built-ins are in, range/3 can be added.
-queens(L, Qs) :- permute(L, Qs), safe(Qs).
-
-permute([], []).
-permute(L, [H|T]) :- select(H, L, R), permute(R, T).
-
-select(X, [X|T], T).
-select(X, [H|T], [H|R]) :- select(X, T, R).
-
-safe([]).
-safe([Q|Qs]) :- safe(Qs), no_attack(Q, Qs, 1).
-
-no_attack(_, [], _).
-no_attack(Q, [Q1|Qs], D) :-
-  is(D2, +(Q, D)),
-  \=(D2, Q1),
-  is(D3, -(Q, D)),
-  \=(D3, Q1),
-  is(D1, +(D, 1)),
-  no_attack(Q, Qs, D1).

lib/prolog/tests/programs/nqueens.sx

@@ -1,108 +0,0 @@
-;; lib/prolog/tests/programs/nqueens.sx — N-queens via permute + safe.
-
-(define pl-nq-test-count 0)
-(define pl-nq-test-pass 0)
-(define pl-nq-test-fail 0)
-(define pl-nq-test-failures (list))
-
-(define
-  pl-nq-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-nq-test-count (+ pl-nq-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-nq-test-pass (+ pl-nq-test-pass 1))
-        (begin
-          (set! pl-nq-test-fail (+ pl-nq-test-fail 1))
-          (append!
-            pl-nq-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-nq-term-to-sx
-  (fn
-    (t)
-    (cond
-      ((pl-num? t) (pl-num-val t))
-      ((pl-atom? t) (pl-atom-name t))
-      (true (list :complex)))))
-
-(define
-  pl-nq-list-walked
-  (fn
-    (w)
-    (cond
-      ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
-      ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
-        (cons
-          (pl-nq-term-to-sx (first (pl-args w)))
-          (pl-nq-list-walked (nth (pl-args w) 1))))
-      (true (list :not-list)))))
-
-(define pl-nq-list-to-sx (fn (t) (pl-nq-list-walked (pl-walk-deep t))))
-
-(define
-  pl-nq-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define
-  pl-nq-prog-src
-  "queens(L, Qs) :- permute(L, Qs), safe(Qs). permute([], []). permute(L, [H|T]) :- select(H, L, R), permute(R, T). select(X, [X|T], T). select(X, [H|T], [H|R]) :- select(X, T, R). safe([]). safe([Q|Qs]) :- safe(Qs), no_attack(Q, Qs, 1). no_attack(_, [], _). no_attack(Q, [Q1|Qs], D) :- is(D2, +(Q, D)), \\=(D2, Q1), is(D3, -(Q, D)), \\=(D3, Q1), is(D1, +(D, 1)), no_attack(Q, Qs, D1).")
-
-(define pl-nq-db (pl-mk-db))
-(pl-db-load! pl-nq-db (pl-parse pl-nq-prog-src))
-
-(pl-nq-test!
-  "queens([1], Qs) → 1 solution"
-  (pl-solve-count!
-    pl-nq-db
-    (pl-nq-goal "queens([1], Qs)" {})
-    (pl-mk-trail))
-  1)
-
-(pl-nq-test!
-  "queens([1, 2], Qs) → 0 solutions"
-  (pl-solve-count!
-    pl-nq-db
-    (pl-nq-goal "queens([1, 2], Qs)" {})
-    (pl-mk-trail))
-  0)
-
-(pl-nq-test!
-  "queens([1, 2, 3], Qs) → 0 solutions"
-  (pl-solve-count!
-    pl-nq-db
-    (pl-nq-goal "queens([1, 2, 3], Qs)" {})
-    (pl-mk-trail))
-  0)
-
-(pl-nq-test!
-  "queens([1, 2, 3, 4], Qs) → 2 solutions"
-  (pl-solve-count!
-    pl-nq-db
-    (pl-nq-goal "queens([1, 2, 3, 4], Qs)" {})
-    (pl-mk-trail))
-  2)
-
-(pl-nq-test!
-  "queens([1, 2, 3, 4, 5], Qs) → 10 solutions"
-  (pl-solve-count!
-    pl-nq-db
-    (pl-nq-goal "queens([1, 2, 3, 4, 5], Qs)" {})
-    (pl-mk-trail))
-  10)
-
-(define pl-nq-env-1 {})
-(define pl-nq-goal-1 (pl-nq-goal "queens([1, 2, 3, 4], Qs)" pl-nq-env-1))
-(pl-solve-once! pl-nq-db pl-nq-goal-1 (pl-mk-trail))
-
-(pl-nq-test!
-  "queens([1..4], Qs) first solution = [2, 4, 1, 3]"
-  (pl-nq-list-to-sx (dict-get pl-nq-env-1 "Qs"))
-  (list 2 4 1 3))
-
-(define pl-nqueens-tests-run! (fn () {:failed pl-nq-test-fail :passed pl-nq-test-pass :total pl-nq-test-count :failures pl-nq-test-failures}))

lib/prolog/tests/programs/reverse.pl

@@ -1,7 +0,0 @@
-%% reverse/2 — naive reverse via append/3.
-%% Quadratic — accumulates the reversed prefix one append per cons.
-reverse([], []).
-reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R).
-
-append([], L, L).
-append([H|T], L, [H|R]) :- append(T, L, R).

lib/prolog/tests/programs/reverse.sx

@@ -1,113 +0,0 @@
-;; lib/prolog/tests/programs/reverse.sx — naive reverse/2 via append/3.
-;;
-;; Mirrors reverse.pl (embedded as a string here).
-
-(define pl-rv-test-count 0)
-(define pl-rv-test-pass 0)
-(define pl-rv-test-fail 0)
-(define pl-rv-test-failures (list))
-
-(define
-  pl-rv-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-rv-test-count (+ pl-rv-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-rv-test-pass (+ pl-rv-test-pass 1))
-        (begin
-          (set! pl-rv-test-fail (+ pl-rv-test-fail 1))
-          (append!
-            pl-rv-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-rv-term-to-sx
-  (fn
-    (t)
-    (cond
-      ((pl-num? t) (pl-num-val t))
-      ((pl-atom? t) (pl-atom-name t))
-      (true (list :complex)))))
-
-(define
-  pl-rv-list-walked
-  (fn
-    (w)
-    (cond
-      ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
-      ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
-        (cons
-          (pl-rv-term-to-sx (first (pl-args w)))
-          (pl-rv-list-walked (nth (pl-args w) 1))))
-      (true (list :not-list)))))
-
-(define pl-rv-list-to-sx (fn (t) (pl-rv-list-walked (pl-walk-deep t))))
-
-(define
-  pl-rv-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define
-  pl-rv-prog-src
-  "reverse([], []). reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R). append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
-
-(define pl-rv-db (pl-mk-db))
-(pl-db-load! pl-rv-db (pl-parse pl-rv-prog-src))
-
-(define pl-rv-env-1 {})
-(define pl-rv-goal-1 (pl-rv-goal "reverse([], X)" pl-rv-env-1))
-(pl-solve-once! pl-rv-db pl-rv-goal-1 (pl-mk-trail))
-
-(pl-rv-test!
-  "reverse([], X) → X = []"
-  (pl-rv-list-to-sx (dict-get pl-rv-env-1 "X"))
-  (list))
-
-(define pl-rv-env-2 {})
-(define pl-rv-goal-2 (pl-rv-goal "reverse([1], X)" pl-rv-env-2))
-(pl-solve-once! pl-rv-db pl-rv-goal-2 (pl-mk-trail))
-
-(pl-rv-test!
-  "reverse([1], X) → X = [1]"
-  (pl-rv-list-to-sx (dict-get pl-rv-env-2 "X"))
-  (list 1))
-
-(define pl-rv-env-3 {})
-(define pl-rv-goal-3 (pl-rv-goal "reverse([1, 2, 3], X)" pl-rv-env-3))
-(pl-solve-once! pl-rv-db pl-rv-goal-3 (pl-mk-trail))
-
-(pl-rv-test!
-  "reverse([1, 2, 3], X) → X = [3, 2, 1]"
-  (pl-rv-list-to-sx (dict-get pl-rv-env-3 "X"))
-  (list 3 2 1))
-
-(define pl-rv-env-4 {})
-(define pl-rv-goal-4 (pl-rv-goal "reverse([a, b, c, d], X)" pl-rv-env-4))
-(pl-solve-once! pl-rv-db pl-rv-goal-4 (pl-mk-trail))
-
-(pl-rv-test!
-  "reverse([a, b, c, d], X) → X = [d, c, b, a]"
-  (pl-rv-list-to-sx (dict-get pl-rv-env-4 "X"))
-  (list "d" "c" "b" "a"))
-
-(pl-rv-test!
-  "reverse([1, 2, 3], [3, 2, 1]) succeeds"
-  (pl-solve-once!
-    pl-rv-db
-    (pl-rv-goal "reverse([1, 2, 3], [3, 2, 1])" {})
-    (pl-mk-trail))
-  true)
-
-(pl-rv-test!
-  "reverse([1, 2], [1, 2]) fails"
-  (pl-solve-once!
-    pl-rv-db
-    (pl-rv-goal "reverse([1, 2], [1, 2])" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-reverse-tests-run! (fn () {:failed pl-rv-test-fail :passed pl-rv-test-pass :total pl-rv-test-count :failures pl-rv-test-failures}))

lib/prolog/tests/solve.sx

@@ -1,618 +0,0 @@
-;; lib/prolog/tests/solve.sx — DFS solver unit tests
-
-(define pl-s-test-count 0)
-(define pl-s-test-pass 0)
-(define pl-s-test-fail 0)
-(define pl-s-test-failures (list))
-
-(define
-  pl-s-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-s-test-count (+ pl-s-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-s-test-pass (+ pl-s-test-pass 1))
-        (begin
-          (set! pl-s-test-fail (+ pl-s-test-fail 1))
-          (append!
-            pl-s-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-s-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define pl-s-empty-db (pl-mk-db))
-
-(pl-s-test!
-  "true succeeds"
-  (pl-solve-once! pl-s-empty-db (pl-s-goal "true" {}) (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "fail fails"
-  (pl-solve-once! pl-s-empty-db (pl-s-goal "fail" {}) (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "= identical atoms"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "=(a, a)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "= different atoms"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "=(a, b)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "= var to atom"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "=(X, foo)" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-s-env-bind {})
-(define pl-s-trail-bind (pl-mk-trail))
-(define pl-s-goal-bind (pl-s-goal "=(X, foo)" pl-s-env-bind))
-(pl-solve-once! pl-s-empty-db pl-s-goal-bind pl-s-trail-bind)
-
-(pl-s-test!
-  "X bound to foo after =(X, foo)"
-  (pl-atom-name (pl-walk-deep (dict-get pl-s-env-bind "X")))
-  "foo")
-
-(pl-s-test!
-  "true , true succeeds"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "true, true" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "true , fail fails"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "true, fail" {})
-    (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "consistent X bindings succeed"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "=(X, a), =(X, a)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "conflicting X bindings fail"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "=(X, a), =(X, b)" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-s-db1 (pl-mk-db))
-(pl-db-load!
-  pl-s-db1
-  (pl-parse "parent(tom, bob). parent(bob, liz). parent(bob, ann)."))
-
-(pl-s-test!
-  "fact lookup hit"
-  (pl-solve-once!
-    pl-s-db1
-    (pl-s-goal "parent(tom, bob)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "fact lookup miss"
-  (pl-solve-once!
-    pl-s-db1
-    (pl-s-goal "parent(tom, liz)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "all parent solutions"
-  (pl-solve-count!
-    pl-s-db1
-    (pl-s-goal "parent(X, Y)" {})
-    (pl-mk-trail))
-  3)
-
-(pl-s-test!
-  "fixed first arg solutions"
-  (pl-solve-count!
-    pl-s-db1
-    (pl-s-goal "parent(bob, Y)" {})
-    (pl-mk-trail))
-  2)
-
-(define pl-s-db2 (pl-mk-db))
-(pl-db-load!
-  pl-s-db2
-  (pl-parse
-    "parent(tom, bob). parent(bob, ann). ancestor(X, Y) :- parent(X, Y). ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
-
-(pl-s-test!
-  "rule direct ancestor"
-  (pl-solve-once!
-    pl-s-db2
-    (pl-s-goal "ancestor(tom, bob)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "rule transitive ancestor"
-  (pl-solve-once!
-    pl-s-db2
-    (pl-s-goal "ancestor(tom, ann)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "rule no path"
-  (pl-solve-once!
-    pl-s-db2
-    (pl-s-goal "ancestor(ann, tom)" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-s-env-undo {})
-(define pl-s-trail-undo (pl-mk-trail))
-(define pl-s-goal-undo (pl-s-goal "=(X, a), fail" pl-s-env-undo))
-(pl-solve-once! pl-s-empty-db pl-s-goal-undo pl-s-trail-undo)
-
-(pl-s-test!
-  "trail undone after failure leaves X unbound"
-  (pl-var-bound? (dict-get pl-s-env-undo "X"))
-  false)
-
-(define pl-s-db-cut1 (pl-mk-db))
-
-(pl-db-load! pl-s-db-cut1 (pl-parse "g :- !. g :- true."))
-
-(pl-s-test!
-  "bare cut succeeds"
-  (pl-solve-once! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "cut commits to first matching clause"
-  (pl-solve-count! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
-  1)
-
-(define pl-s-db-cut2 (pl-mk-db))
-
-(pl-db-load! pl-s-db-cut2 (pl-parse "a(1). a(2). g(X) :- a(X), !."))
-
-(pl-s-test!
-  "cut commits to first a solution"
-  (pl-solve-count! pl-s-db-cut2 (pl-s-goal "g(X)" {}) (pl-mk-trail))
-  1)
-
-(define pl-s-db-cut3 (pl-mk-db))
-
-(pl-db-load!
-  pl-s-db-cut3
-  (pl-parse "a(1). a(2). g(X) :- a(X), !, fail. g(99)."))
-
-(pl-s-test!
-  "cut then fail blocks alt clauses"
-  (pl-solve-count! pl-s-db-cut3 (pl-s-goal "g(X)" {}) (pl-mk-trail))
-  0)
-
-(define pl-s-db-cut4 (pl-mk-db))
-
-(pl-db-load!
-  pl-s-db-cut4
-  (pl-parse "a(1). b(10). b(20). g(X, Y) :- a(X), !, b(Y)."))
-
-(pl-s-test!
-  "post-cut goal backtracks freely"
-  (pl-solve-count!
-    pl-s-db-cut4
-    (pl-s-goal "g(X, Y)" {})
-    (pl-mk-trail))
-  2)
-
-(define pl-s-db-cut5 (pl-mk-db))
-
-(pl-db-load!
-  pl-s-db-cut5
-  (pl-parse "r(1). r(2). q :- r(X), !. p :- q. p :- true."))
-
-(pl-s-test!
-  "inner cut does not commit outer predicate"
-  (pl-solve-count! pl-s-db-cut5 (pl-s-goal "p" {}) (pl-mk-trail))
-  2)
-
-(pl-s-test!
-  "\\= different atoms succeeds"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "\\=(a, b)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "\\= same atoms fails"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "\\=(a, a)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "\\= var-vs-atom would unify so fails"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "\\=(X, a)" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-s-env-ne {})
-
-(define pl-s-trail-ne (pl-mk-trail))
-
-(define pl-s-goal-ne (pl-s-goal "\\=(X, a)" pl-s-env-ne))
-
-(pl-solve-once! pl-s-empty-db pl-s-goal-ne pl-s-trail-ne)
-
-(pl-s-test!
-  "\\= leaves no bindings"
-  (pl-var-bound? (dict-get pl-s-env-ne "X"))
-  false)
-
-(pl-s-test!
-  "; left succeeds"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal ";(true, fail)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "; right succeeds when left fails"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal ";(fail, true)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "; both fail"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal ";(fail, fail)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "; both branches counted"
-  (pl-solve-count!
-    pl-s-empty-db
-    (pl-s-goal ";(true, true)" {})
-    (pl-mk-trail))
-  2)
-
-(define pl-s-db-call (pl-mk-db))
-
-(pl-db-load! pl-s-db-call (pl-parse "p(1). p(2)."))
-
-(pl-s-test!
-  "call(true) succeeds"
-  (pl-solve-once!
-    pl-s-db-call
-    (pl-s-goal "call(true)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "call(p(X)) yields all solutions"
-  (pl-solve-count!
-    pl-s-db-call
-    (pl-s-goal "call(p(X))" {})
-    (pl-mk-trail))
-  2)
-
-(pl-s-test!
-  "call of bound goal var resolves"
-  (pl-solve-once!
-    pl-s-db-call
-    (pl-s-goal "=(G, true), call(G)" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-s-db-ite (pl-mk-db))
-
-(pl-db-load! pl-s-db-ite (pl-parse "p(1). p(2). q(yes). q(no)."))
-
-(pl-s-test!
-  "if-then-else: cond true → then runs"
-  (pl-solve-once!
-    pl-s-db-ite
-    (pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-s-env-ite1 {})
-
-(pl-solve-once!
-  pl-s-db-ite
-  (pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" pl-s-env-ite1)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "if-then-else: cond true binds via then"
-  (pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite1 "X")))
-  "ok")
-
-(pl-s-test!
-  "if-then-else: cond false → else"
-  (pl-solve-once!
-    pl-s-db-ite
-    (pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-s-env-ite2 {})
-
-(pl-solve-once!
-  pl-s-db-ite
-  (pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" pl-s-env-ite2)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "if-then-else: cond false binds via else"
-  (pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite2 "X")))
-  "fallback")
-
-(pl-s-test!
-  "if-then-else: cond commits to first solution (count = 1)"
-  (pl-solve-count!
-    pl-s-db-ite
-    (pl-s-goal ";(->(p(X), =(Y, found)), =(Y, none))" {})
-    (pl-mk-trail))
-  1)
-
-(pl-s-test!
-  "if-then-else: then can backtrack"
-  (pl-solve-count!
-    pl-s-db-ite
-    (pl-s-goal ";(->(true, p(X)), =(X, none))" {})
-    (pl-mk-trail))
-  2)
-
-(pl-s-test!
-  "if-then-else: else can backtrack"
-  (pl-solve-count!
-    pl-s-db-ite
-    (pl-s-goal ";(->(fail, =(X, ignored)), p(X))" {})
-    (pl-mk-trail))
-  2)
-
-(pl-s-test!
-  "standalone -> with true cond succeeds"
-  (pl-solve-once!
-    pl-s-db-ite
-    (pl-s-goal "->(true, =(X, hi))" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "standalone -> with false cond fails"
-  (pl-solve-once!
-    pl-s-db-ite
-    (pl-s-goal "->(fail, =(X, hi))" {})
-    (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "write(hello)"
-  (begin
-    (pl-output-clear!)
-    (pl-solve-once!
-      pl-s-empty-db
-      (pl-s-goal "write(hello)" {})
-      (pl-mk-trail))
-    pl-output-buffer)
-  "hello")
-
-(pl-s-test!
-  "nl outputs newline"
-  (begin
-    (pl-output-clear!)
-    (pl-solve-once! pl-s-empty-db (pl-s-goal "nl" {}) (pl-mk-trail))
-    pl-output-buffer)
-  "\n")
-
-(pl-s-test!
-  "write(42) outputs digits"
-  (begin
-    (pl-output-clear!)
-    (pl-solve-once!
-      pl-s-empty-db
-      (pl-s-goal "write(42)" {})
-      (pl-mk-trail))
-    pl-output-buffer)
-  "42")
-
-(pl-s-test!
-  "write(foo(a, b)) formats compound"
-  (begin
-    (pl-output-clear!)
-    (pl-solve-once!
-      pl-s-empty-db
-      (pl-s-goal "write(foo(a, b))" {})
-      (pl-mk-trail))
-    pl-output-buffer)
-  "foo(a, b)")
-
-(pl-s-test!
-  "write conjunction"
-  (begin
-    (pl-output-clear!)
-    (pl-solve-once!
-      pl-s-empty-db
-      (pl-s-goal "write(a), write(b)" {})
-      (pl-mk-trail))
-    pl-output-buffer)
-  "ab")
-
-(pl-s-test!
-  "write of bound var walks binding"
-  (begin
-    (pl-output-clear!)
-    (pl-solve-once!
-      pl-s-empty-db
-      (pl-s-goal "=(X, hello), write(X)" {})
-      (pl-mk-trail))
-    pl-output-buffer)
-  "hello")
-
-(pl-s-test!
-  "write then nl"
-  (begin
-    (pl-output-clear!)
-    (pl-solve-once!
-      pl-s-empty-db
-      (pl-s-goal "write(hi), nl" {})
-      (pl-mk-trail))
-    pl-output-buffer)
-  "hi\n")
-
-(define pl-s-env-arith1 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, 42)" pl-s-env-arith1)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, 42) binds X to 42"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith1 "X")))
-  42)
-
-(define pl-s-env-arith2 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, +(2, 3))" pl-s-env-arith2)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, +(2, 3)) binds X to 5"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith2 "X")))
-  5)
-
-(define pl-s-env-arith3 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, *(2, 3))" pl-s-env-arith3)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, *(2, 3)) binds X to 6"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith3 "X")))
-  6)
-
-(define pl-s-env-arith4 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, -(10, 3))" pl-s-env-arith4)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, -(10, 3)) binds X to 7"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith4 "X")))
-  7)
-
-(define pl-s-env-arith5 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, /(10, 2))" pl-s-env-arith5)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, /(10, 2)) binds X to 5"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith5 "X")))
-  5)
-
-(define pl-s-env-arith6 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, mod(10, 3))" pl-s-env-arith6)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, mod(10, 3)) binds X to 1"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith6 "X")))
-  1)
-
-(define pl-s-env-arith7 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, abs(-(0, 5)))" pl-s-env-arith7)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, abs(-(0, 5))) binds X to 5"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith7 "X")))
-  5)
-
-(define pl-s-env-arith8 {})
-
-(pl-solve-once!
-  pl-s-empty-db
-  (pl-s-goal "is(X, +(2, *(3, 4)))" pl-s-env-arith8)
-  (pl-mk-trail))
-
-(pl-s-test!
-  "is(X, +(2, *(3, 4))) binds X to 14 (nested)"
-  (pl-num-val (pl-walk-deep (dict-get pl-s-env-arith8 "X")))
-  14)
-
-(pl-s-test!
-  "is(5, +(2, 3)) succeeds (LHS num matches)"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "is(5, +(2, 3))" {})
-    (pl-mk-trail))
-  true)
-
-(pl-s-test!
-  "is(6, +(2, 3)) fails (LHS num mismatch)"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "is(6, +(2, 3))" {})
-    (pl-mk-trail))
-  false)
-
-(pl-s-test!
-  "is propagates bound vars on RHS"
-  (pl-solve-once!
-    pl-s-empty-db
-    (pl-s-goal "=(Y, 4), is(X, +(Y, 1)), =(X, 5)" {})
-    (pl-mk-trail))
-  true)
-
-(define pl-solve-tests-run! (fn () {:failed pl-s-test-fail :passed pl-s-test-pass :total pl-s-test-count :failures pl-s-test-failures}))

lib/prolog/tests/term_inspect.sx

@@ -1,147 +0,0 @@
-;; lib/prolog/tests/term_inspect.sx — copy_term/2, functor/3, arg/3.
-
-(define pl-tt-test-count 0)
-(define pl-tt-test-pass 0)
-(define pl-tt-test-fail 0)
-(define pl-tt-test-failures (list))
-
-(define
-  pl-tt-test!
-  (fn
-    (name got expected)
-    (begin
-      (set! pl-tt-test-count (+ pl-tt-test-count 1))
-      (if
-        (= got expected)
-        (set! pl-tt-test-pass (+ pl-tt-test-pass 1))
-        (begin
-          (set! pl-tt-test-fail (+ pl-tt-test-fail 1))
-          (append!
-            pl-tt-test-failures
-            (str name "\n    expected: " expected "\n    got:      " got)))))))
-
-(define
-  pl-tt-goal
-  (fn
-    (src env)
-    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
-
-(define pl-tt-db (pl-mk-db))
-
-;; ── copy_term/2 ──
-
-(pl-tt-test!
-  "copy_term ground compound succeeds + copy = original"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "copy_term(foo(a, b), X), X = foo(a, b)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-tt-test!
-  "copy_term preserves var aliasing in source"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 5" {})
-    (pl-mk-trail))
-  true)
-
-(pl-tt-test!
-  "copy_term distinct vars stay distinct"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 6" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-tt-env-1 {})
-(pl-solve-once!
-  pl-tt-db
-  (pl-tt-goal "copy_term(X, Y), Y = 5" pl-tt-env-1)
-  (pl-mk-trail))
-(pl-tt-test!
-  "copy_term: binding the copy doesn't bind the source"
-  (pl-var-bound? (dict-get pl-tt-env-1 "X"))
-  false)
-
-;; ── functor/3 ──
-
-(define pl-tt-env-2 {})
-(pl-solve-once!
-  pl-tt-db
-  (pl-tt-goal "functor(foo(a, b, c), F, N)" pl-tt-env-2)
-  (pl-mk-trail))
-(pl-tt-test!
-  "functor of compound: F = foo"
-  (pl-atom-name (pl-walk-deep (dict-get pl-tt-env-2 "F")))
-  "foo")
-(pl-tt-test!
-  "functor of compound: N = 3"
-  (pl-num-val (pl-walk-deep (dict-get pl-tt-env-2 "N")))
-  3)
-
-(define pl-tt-env-3 {})
-(pl-solve-once!
-  pl-tt-db
-  (pl-tt-goal "functor(hello, F, N)" pl-tt-env-3)
-  (pl-mk-trail))
-(pl-tt-test!
-  "functor of atom: F = hello"
-  (pl-atom-name (pl-walk-deep (dict-get pl-tt-env-3 "F")))
-  "hello")
-(pl-tt-test!
-  "functor of atom: N = 0"
-  (pl-num-val (pl-walk-deep (dict-get pl-tt-env-3 "N")))
-  0)
-
-(pl-tt-test!
-  "functor construct compound: T unifies with foo(a, b)"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "functor(T, foo, 2), T = foo(a, b)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-tt-test!
-  "functor construct atom: T = hello"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "functor(T, hello, 0), T = hello" {})
-    (pl-mk-trail))
-  true)
-
-;; ── arg/3 ──
-
-(pl-tt-test!
-  "arg(1, foo(a, b, c), a)"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "arg(1, foo(a, b, c), a)" {})
-    (pl-mk-trail))
-  true)
-
-(pl-tt-test!
-  "arg(2, foo(a, b, c), X) → X = b"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "arg(2, foo(a, b, c), X), X = b" {})
-    (pl-mk-trail))
-  true)
-
-(pl-tt-test!
-  "arg out-of-range high fails"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "arg(4, foo(a, b, c), X)" {})
-    (pl-mk-trail))
-  false)
-
-(pl-tt-test!
-  "arg(0, ...) fails (1-indexed)"
-  (pl-solve-once!
-    pl-tt-db
-    (pl-tt-goal "arg(0, foo(a), X)" {})
-    (pl-mk-trail))
-  false)
-
-(define pl-term-inspect-tests-run! (fn () {:failed pl-tt-test-fail :passed pl-tt-test-pass :total pl-tt-test-count :failures pl-tt-test-failures}))

plans/haskell-on-sx.md

@@ -55,27 +55,34 @@ Key mappings:
 
 ### Phase 1 — tokenizer + parser + layout rule
 - [x] Tokenizer: reserved words, qualified names, operators, numbers (int, float, Rational later), chars/strings, comments (`--` and `{-` nested)
-- [ ] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
+- [x] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
-- [ ] Parser: modules, imports (stub), top-level decls, type sigs, function clauses with patterns + guards + where-clauses, expressions with operator precedence, lambdas, `let`, `if`, `case`, `do`, list comp, sections
+- Parser (split into sub-items — implement one per iteration):
-- [ ] AST design modelled on GHC's HsSyn at a surface level
+  - [x] Expressions: atoms, parens, tuples, lists, ranges, application, infix with full Haskell-98 precedence table, unary `-`, backtick operators, lambdas, `if`, `let`
+  - [x] `case … of` and `do`-notation expressions (plus minimal patterns needed for arms/binds: var, wildcard, literal, 0-arity and applied constructor, tuple, list)
+  - [x] Patterns — full: `as` patterns, nested, negative literal, `~` lazy, infix constructor (`:` / consym), extend lambdas/let with non-var patterns
+  - [x] Top-level decls: function clauses (simple — no guards/where yet), pattern bindings, multi-name type signatures, `data` with type vars and recursive constructors, `type` synonyms, `newtype`, fixity (`infix`/`infixl`/`infixr` with optional precedence, comma-separated ops, backtick names). Types: vars / constructors / application / `->` (right-assoc) / tuples / lists. `hk-parse-top` entry.
+  - [x] `where` clauses + guards (on fun-clauses, case alts, and let/do-let bindings — with the let funclause shorthand `let f x = …` now supported)
+  - [x] Module header + imports — `module NAME [exports] where …`, qualified/as/hiding/explicit imports, operator exports, `module Foo` exports, dotted names, headerless-with-imports
+  - [x] List comprehensions + operator sections — `(op)` / `(op e)` / `(e op)` (excluding `-` from right sections), `[e | q1, q2, …]` with `q-gen` / `q-guard` / `q-let` qualifiers
+- [x] AST design modelled on GHC's HsSyn at a surface level — keyword-tagged lists cover modules/imports/decls/types/patterns/expressions; see parser.sx docstrings for the full node catalogue
 - [x] Unit tests in `lib/haskell/tests/parse.sx` (43 tokenizer tests, all green)
 
 ### Phase 2 — desugar + eager-ish eval + ADTs (untyped)
-- [ ] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3)
+- [x] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3)
-- [ ] `data` declarations register constructors in runtime
+- [x] `data` declarations register constructors in runtime
-- [ ] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested
+- [x] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested
-- [ ] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
+- [x] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
-- [ ] 30+ eval tests in `lib/haskell/tests/eval.sx`
+- [x] 30+ eval tests in `lib/haskell/tests/eval.sx`
 
 ### Phase 3 — laziness + classic programs
-- [ ] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
+- [x] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
-- [ ] `force` = SX eval-thunk-to-WHNF primitive
+- [x] `force` = SX eval-thunk-to-WHNF primitive
-- [ ] Pattern match forces scrutinee before matching
+- [x] Pattern match forces scrutinee before matching
-- [ ] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream, sieve of Eratosthenes
+- [x] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream (sieve deferred — needs lazy `++` and is exercised under `Classic programs`)
-- [ ] `seq`, `deepseq` from Prelude
+- [x] `seq`, `deepseq` from Prelude
-- [ ] Do-notation for a stub `IO` monad (just threading, no real side effects yet)
+- [x] Do-notation for a stub `IO` monad (just threading, no real side effects yet)
 - [ ] Classic programs in `lib/haskell/tests/programs/`:
-  - [ ] `fib.hs` — infinite Fibonacci stream
+  - [x] `fib.hs` — infinite Fibonacci stream
   - [ ] `sieve.hs` — lazy sieve of Eratosthenes
   - [ ] `quicksort.hs` — naive QS
   - [ ] `nqueens.hs`
@@ -107,6 +114,398 @@ Key mappings:
 
 _Newest first._
 
+- **2026-04-25** — First classic program: `fib.hs`. Canonical Haskell
+  source lives at `lib/haskell/tests/programs/fib.hs` (the
+  two-cons-cell self-referential fibs definition plus a hand-rolled
+  `zipPlus`). The runner at `lib/haskell/tests/program-fib.sx`
+  mirrors the source as an SX string (the OCaml server's
+  `read-file` lives in the page-helpers env, not the default load
+  env, so direct file reads from inside `eval` aren't available).
+  Tests: `take 15 myFibs == [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377]`,
+  plus a spot-check that the user-defined `zipPlus` is also
+  reachable. Found and fixed an ordering bug in `hk-bind-decls!`:
+  pass 3 (0-arity body evaluation) iterated `(keys groups)` whose
+  order is implementation-defined, so a top-down program where
+  `result = take 15 myFibs` came after `myFibs = …` could see
+  `myFibs` still bound to its `nil` placeholder. Now group names
+  are tracked in source order via a parallel list and pass 3 walks
+  that. 388/388 green.
+
+- **2026-04-25** — Phase 3 do-notation + stub IO monad. Added a
+  `hk-desugar-do` pass that follows Haskell 98 §3.14 verbatim:
+  `do { e } = e`, `do { e ; ss } = e >> do { ss }`,
+  `do { p <- e ; ss } = e >>= \p -> do { ss }`, and
+  `do { let ds ; ss } = let ds in do { ss }`. The desugarer's
+  `:do` branch now invokes this pass directly so the surface
+  AST forms (`:do-expr`, `:do-bind`, `:do-let`) never reach the
+  evaluator. IO is represented as a tagged value
+  `("IO" payload)` — `return` (lazy builtin) wraps; `>>=` (lazy
+  builtin) forces the action, unwraps, and calls the bound
+  function on the payload; `>>` (lazy builtin) forces the
+  action and returns the second one. All three are non-strict
+  in their action arguments so deeply nested do-blocks don't
+  walk the whole chain at construction time. 14 new tests in
+  `lib/haskell/tests/do-io.sx` cover single-stmt do, single
+  and multi-bind, `>>` sequencing (last action wins), do-let
+  (single, multi, interleaved with bind), bind-to-`Just`,
+  bind-to-tuple, do inside a top-level fun, nested do, and
+  using `(>>=)`/`(>>)` directly as functions. 382/382 green.
+
+- **2026-04-25** — Phase 3 `seq` + `deepseq`. Built-ins were strict
+  in all args by default (every collected thunk forced before
+  invoking the underlying SX fn) — that defeats `seq`'s purpose,
+  which is strict in its first argument and lazy in its second.
+  Added a tiny `lazy` flag on the builtin record (set by a new
+  `hk-mk-lazy-builtin` constructor) and routed `hk-apply-builtin`
+  to skip the auto-force when the flag is true. `seq a b` calls
+  `hk-force a` then returns `b` unchanged so its laziness is
+  preserved; `deepseq` does the same with `hk-deep-force`. 9 new
+  tests in `lib/haskell/tests/seq.sx` cover primitive, computed,
+  and let-bound first args, deepseq on a list / `Just` /
+  tuple, seq inside arithmetic, seq via a fun-clause, and
+  `[seq 1 10, seq 2 20]` to confirm seq composes inside list
+  literals. The lazy-when-unused negative case is also tested:
+  `let x = error "never" in 42 == 42`. 368/368 green.
+
+- **2026-04-24** — Phase 3 infinite structures + Prelude. Two
+  evaluator changes turn the lazy primitives into a working
+  language:
+  1. Op-form `:` is now non-strict in both args — `hk-eval-op`
+     special-cases it before the eager force-and-binop path, so a
+     cons-cell holds two thunks. This is what makes `repeat x =
+     x : repeat x`, `iterate f x = x : iterate f (f x)`, and the
+     classic `fibs = 0 : 1 : zipWith plus fibs (tail fibs)`
+     terminate when only a finite prefix is consumed.
+  2. Operators are now first-class values via a small
+     `hk-make-binop-builtin` helper, so `(+)`, `(*)`, `(==)` etc.
+     can be passed to `zipWith` and `map`.
+  Added range support across parser + evaluator: `[from..to]` and
+  `[from,next..to]` evaluate eagerly via `hk-build-range` (handles
+  step direction); `[from..]` parses to a new `:range-from` node
+  that the evaluator desugars to `iterate (+ 1) from`. New
+  `hk-load-into!` runs the regular pipeline (parse → desugar →
+  register data → bind decls) on a source string, and `hk-init-env`
+  preloads `hk-prelude-src` with the Phase-3 Prelude:
+  `head`, `tail`, `fst`, `snd`, `take`, `drop`, `repeat`, `iterate`,
+  `length`, `map`, `filter`, `zipWith`, plus `fibs` and `plus`.
+  25 new tests in `lib/haskell/tests/infinite.sx`, including
+  `take 10 fibs == [0,1,1,2,3,5,8,13,21,34]`,
+  `head (drop 99 [1..])`, `iterate (\x -> x * 2) 1` powers of two,
+  user-defined `ones = 1 : ones`, `naturalsFrom`, range edge cases,
+  composed `map`/`filter`, and a custom `mySum`. 359/359 green.
+  Sieve of Eratosthenes is deferred — it needs lazy `++` plus a
+  `mod` primitive — and lives under `Classic programs` anyway.
+
+- **2026-04-24** — Phase 3 laziness foundation. Added a thunk type to
+  `lib/haskell/eval.sx` (`hk-mk-thunk` / `hk-is-thunk?`) backed by a
+  one-shot memoizing `hk-force` that evaluates the deferred AST, then
+  flips a `forced` flag and caches the value on the thunk dict; the
+  shared `hk-deep-force` walks the result tree at the test/output
+  boundary. Three single-line wiring changes in the evaluator make
+  every application argument lazy: `:app` now wraps its argument in
+  `hk-mk-thunk` rather than evaluating it. To preserve correctness
+  where values must be inspected, `hk-apply`, `hk-eval-op`,
+  `hk-eval-if`, `hk-eval-case`, and `hk-eval` for `:neg` now force
+  their operand. `hk-apply-builtin` forces every collected arg
+  before invoking the underlying SX fn so built-ins (`error`, `not`,
+  `id`) stay strict. The pattern matcher in `match.sx` now forces
+  the scrutinee just-in-time only for patterns that need to inspect
+  shape — `p-wild`, `p-var`, `p-as`, and `p-lazy` are no-force
+  paths, so the value flows through as a thunk and binding
+  preserves laziness. `hk-match-list-pat` forces at every cons-spine
+  step. 6 new lazy-specific tests in `lib/haskell/tests/eval.sx`
+  verify that `(\x y -> x) 1 (error …)` and `(\x y -> y) (error …) 99`
+  return without diverging, that `case Just (error …) of Just _ -> 7`
+  short-circuits, that `const` drops its second arg, that
+  `myHead (1 : error … : [])` returns 1 without touching the tail,
+  and that `Just (error …)` survives a wildcard-arm `case`. 333/333
+  green, all prior eval tests preserved by deep-forcing the result
+  in `hk-eval-expr-source` and `hk-prog-val`.
+
+- **2026-04-24** — Phase 2 evaluator (`lib/haskell/eval.sx`) — ties
+  the whole pipeline together. Strict semantics throughout (laziness
+  is Phase 3). Function values are tagged dicts: `closure`,
+  `multi`(fun), `con-partial`, `builtin`. `hk-apply` unifies dispatch
+  across all four; closures and multifuns curry one argument at a
+  time, multifuns trying each clause's pat-list in order once arity
+  is reached. Top-level `hk-bind-decls!` is three-pass —
+  collect groups + pre-seed names → install multifuns (so closures
+  observe later names) → eval 0-arity bodies and pat-binds — making
+  forward and mutually recursive references work. `hk-eval-let` does
+  the same trick with a mutable child env. Built-ins:
+  `error`/`not`/`id`, plus `otherwise = True`. Operators wired:
+  arithmetic, comparison (returning Bool conses), `&&`, `||`, `:`,
+  `++`. Sections evaluate the captured operand once and return a
+  closure synthesized via the existing AST. `hk-eval-program`
+  registers data decls then binds, returning the env; `hk-run`
+  fetches `main` if present. Also extended `runtime.sx` to
+  pre-register the standard Prelude conses (`Maybe`, `Either`,
+  `Ordering`) so expression-level eval doesn't need a leading
+  `data` decl. 48 new tests in `lib/haskell/tests/eval.sx` cover
+  literals, arithmetic precedence, comparison/Bool, `if`, `let`
+  (incl. recursive factorial), lambdas (incl. constructor pattern
+  args), constructors, `case` (Just/Nothing/literal/tuple/wildcard),
+  list literals + cons + `++`, tuples, sections, multi-clause
+  top-level (factorial, list length via cons pattern, Maybe handler
+  with default), user-defined `data` with case-style matching, a
+  binary-tree height program, currying, higher-order (`twice`),
+  short-circuit `error` via `if`, and the three built-ins. 329/329
+  green. Phase 2 is now complete; Phase 3 (laziness) is next.
+
+- **2026-04-24** — Phase 2: value-level pattern matcher
+  (`lib/haskell/match.sx`). Core entry `hk-match pat val env` returns
+  an extended env dict on success or `nil` on failure (uses `assoc`
+  rather than `dict-set!` so failed branches never pollute the
+  caller's env). Constructor values are tagged lists with the
+  constructor name as the first element; tuples use the tag `"Tuple"`,
+  lists are chained `(":" h t)` cons cells terminated by `("[]")`.
+  Value builders `hk-mk-con` / `hk-mk-tuple` / `hk-mk-nil` /
+  `hk-mk-cons` / `hk-mk-list` keep tests readable. The matcher
+  handles every pattern node the parser emits:
+  - `:p-wild` (always matches), `:p-var` (binds), `:p-int` /
+    `:p-float` / `:p-string` / `:p-char` (literal equality)
+  - `:p-as` (sub-match then bind whole), `:p-lazy` (eager for now;
+    laziness wired in phase 3)
+  - `:p-con` with arity check + recursive arg matching, including
+    deeply nested patterns and infix `:` cons (uses the same
+    code path as named constructors)
+  - `:p-tuple` against `"Tuple"` values, `:p-list` against an
+    exact-length cons spine.
+  Helper `hk-parse-pat-source` lifts a real Haskell pattern out of
+  `case _ of <pat> -> 0`, letting tests drive against parser output.
+  31 new tests in `lib/haskell/tests/match.sx` cover atomic
+  patterns, success/failure for each con/tuple/list shape, nested
+  `Just (Just x)`, cons-vs-empty, `as` over con / wildcard /
+  failing-sub, `~` lazy, plus four parser-driven cases (`Just x`,
+  `x : xs`, `(a, b)`, `n@(Just x)`). 281/281 green.
+
+- **2026-04-24** — Phase 2: runtime constructor registry
+  (`lib/haskell/runtime.sx`). A mutable dict `hk-constructors` keyed
+  by constructor name, each entry carrying arity and owning type.
+  `hk-register-data!` walks a `:data` AST and registers every
+  `:con-def` with its arity (= number of field types) and the type
+  name; `hk-register-newtype!` does the one-constructor variant;
+  `hk-register-decls!` / `hk-register-program!` filter a decls list
+  (or a `:program` / `:module` AST) and call the appropriate
+  registrar. `hk-load-source!` composes it with `hk-core`
+  (tokenize → layout → parse → desugar → register). Pre-registers
+  five built-ins tied to Haskell syntactic forms: `True` / `False`
+  (Bool), `[]` and `:` (List), `()` (Unit) — everything else comes
+  from user declarations or the eventual Prelude. Query helpers:
+  `hk-is-con?`, `hk-con-arity`, `hk-con-type`, `hk-con-names`. 24
+  new tests in `lib/haskell/tests/runtime.sx` cover each built-in
+  (arity + type), unknown-name probes, registration of `MyBool` /
+  `Maybe` / `Either` / recursive `Tree` / `newtype Age`, multi-data
+  programs, a module-header body, ignoring non-data decls, and
+  last-wins re-registration. 250/250 green.
+
+- **2026-04-24** — Phase 2 kicks off with `lib/haskell/desugar.sx` — a
+  tree-walking rewriter that eliminates the three surface-only forms
+  produced by the parser, leaving a smaller core AST for the evaluator:
+  - `:where BODY DECLS` → `:let DECLS BODY`
+  - `:guarded ((:guard C1 E1) (:guard C2 E2) …)` → right-folded
+    `(:if C1 E1 (:if C2 E2 … (:app (:var "error") (:string "…"))))`
+  - `:list-comp E QUALS` → Haskell 98 §3.11 translation:
+    empty quals → `(:list (E))`, `:q-guard` → `(:if … (:list (E)) (:list ()))`,
+    `:q-gen PAT SRC` → `(concatMap (\PAT -> …) SRC)`, `:q-let BINDS` →
+    `(:let BINDS …)`. Nested generators compile to nested concatMap.
+  Every other expression, decl, pattern, and type node is recursed
+  into and passed through unchanged. Public entries `hk-desugar`,
+  `hk-core` (tokenize → layout → parse → desugar on a module), and
+  `hk-core-expr` (the same for an expression). 15 new tests in
+  `lib/haskell/tests/desugar.sx` cover two- and three-way guards,
+  case-alt guards, single/multi-binding `where`, guards + `where`
+  combined, the four list-comprehension cases (single-gen, gen +
+  filter, gen + let, nested gens), and pass-through for literals,
+  lambdas, simple fun-clauses, `data` decls, and a module header
+  wrapping a guarded function. 226/226 green.
+
+- **2026-04-24** — Phase 1 parser is now complete. This iteration adds
+  operator sections and list comprehensions, the two remaining
+  aexp-level forms, plus ticks the “AST design” item (the keyword-
+  tagged list shape has accumulated a full HsSyn-level surface).
+  Changes:
+  - `hk-parse-infix` now bails on `op )` without consuming the op, so
+    the paren parser can claim it as a left section.
+  - `hk-parse-parens` rewritten to recognise five new forms:
+    `()` (unit), `(op)` → `(:var OP)`, `(op e)` → `(:sect-right OP E)`
+    (excluded for `-` so that `(- 5)` stays `(:neg 5)`), `(e op)` →
+    `(:sect-left OP E)`, plus regular parens and tuples. Works for
+    varsym, consym, reservedop `:`, and backtick-quoted varids.
+  - `hk-section-op-info` inspects the current token and returns a
+    `{:name :len}` dict, so the same logic handles 1-token ops and
+    3-token backtick ops uniformly.
+  - `hk-parse-list-lit` now recognises a `|` after the first element
+    and dispatches to `hk-parse-qual` per qualifier (comma-separated),
+    producing `(:list-comp EXPR QUALS)`. Qualifiers are:
+    `(:q-gen PAT EXPR)` when a paren-balanced lookahead
+    (`hk-comp-qual-is-gen?`) finds `<-` before the next `,`/`]`,
+    `(:q-let BINDS)` for `let …`, and `(:q-guard EXPR)` otherwise.
+  - `hk-parse-comp-let` accepts `]` or `,` as an implicit block close
+    (single-line comprehensions never see layout's vrbrace before the
+    qualifier terminator arrives); explicit `{ }` still closes
+    strictly.
+  22 new tests in `lib/haskell/tests/parser-sect-comp.sx` cover
+  op-references (inc. `(-)`, `(:)`, backtick), right sections (inc.
+  backtick), left sections, the `(- 5)` → `:neg` corner, plain parens
+  and tuples, six comprehension shapes (simple, filter, let,
+  nested-generators, constructor pattern bind, tuple pattern bind,
+  and a three-qualifier mix). 211/211 green.
+
+- **2026-04-24** — Phase 1: module header + imports. Added
+  `hk-parse-module-header`, `hk-parse-import`, plus shared helpers for
+  import/export entity lists (`hk-parse-ent`, `hk-parse-ent-member`,
+  `hk-parse-ent-list`). New AST:
+  - `(:module NAME EXPORTS IMPORTS DECLS)` — NAME `nil` means no header,
+    EXPORTS `nil` means no export list (distinct from empty `()`)
+  - `(:import QUALIFIED NAME AS SPEC)` — QUALIFIED bool, AS alias or nil,
+    SPEC nil / `(:spec-items ENTS)` / `(:spec-hiding ENTS)`
+  - Entity refs: `:ent-var`, `:ent-all` (`Tycon(..)`), `:ent-with`
+    (`Tycon(m1, m2, …)`), `:ent-module` (exports only).
+  `hk-parse-program` now dispatches on the leading token: `module`
+  keyword → full header-plus-body parse (consuming the `where` layout
+  brace around the module body); otherwise collect any leading
+  `import` decls and then remaining decls with the existing logic.
+  The outer shell is `(:module …)` as soon as any header or import is
+  present, and stays as `(:program DECLS)` otherwise — preserving every
+  previous test expectation untouched. Handles operator exports `((+:))`,
+  dotted module names (`Data.Map`), and the Haskell-98 context-sensitive
+  keywords `qualified`/`as`/`hiding` (all lexed as ordinary varids and
+  matched only in import position). 16 new tests in
+  `lib/haskell/tests/parser-module.sx` covering simple/exports/empty
+  headers, dotted names, operator exports, `module Foo` exports,
+  qualified/aliased/items/hiding imports, and a headerless-with-imports
+  file. 189/189 green.
+
+- **2026-04-24** — Phase 1: guards + where clauses. Factored a single
+  `hk-parse-rhs sep` that all body-producing sites now share: it reads
+  a plain `sep expr` body or a chain of `| cond sep expr` guards, then
+  — regardless of which form — looks for an optional `where` block and
+  wraps accordingly. AST additions:
+  - `:guarded GUARDS` where each GUARD is `:guard COND EXPR`
+  - `:where BODY DECLS` where BODY is a plain expr or a `:guarded`
+  Both can nest (guards inside where). `hk-parse-alt` now routes through
+  `hk-parse-rhs "->"`, `hk-parse-fun-clause` and `hk-parse-bind` through
+  `hk-parse-rhs "="`. `hk-parse-where-decls` reuses `hk-parse-decl` so
+  where-blocks accept any decl form (signatures, fixity, nested funs).
+  As a side effect, `hk-parse-bind` now also picks up the Haskell-native
+  `let f x = …` funclause shorthand: a varid followed by one or more
+  apats produces `(:fun-clause NAME APATS BODY)` instead of a
+  `(:bind (:p-var …) …)` — keeping the simple `let x = e` shape
+  unchanged for existing tests. 11 new tests in
+  `lib/haskell/tests/parser-guards-where.sx` cover two- and three-way
+  guards, mixed guarded + equality clauses, single- and multi-binding
+  where blocks, guards plus where, case-alt guards, case-alt where,
+  let with funclause shorthand, let with guards, and a where containing
+  a type signature alongside a fun-clause. 173/173 green.
+
+- **2026-04-24** — Phase 1: top-level decls. Refactored `hk-parse-expr` into a
+  `hk-parser tokens mode` with `:expr` / `:module` dispatch so the big lexical
+  state is shared (peek/advance/pat/expr helpers all reachable); added public
+  wrappers `hk-parse-expr`, `hk-parse-module`, and source-level entry
+  `hk-parse-top`. New type parser (`hk-parse-type` / `hk-parse-btype` /
+  `hk-parse-atype`): type variables (`:t-var`), type constructors (`:t-con`),
+  type application (`:t-app`, left-assoc), right-associative function arrow
+  (`:t-fun`), unit/tuples (`:t-tuple`), and lists (`:t-list`). New decl parser
+  (`hk-parse-decl` / `hk-parse-program`) producing a `(:program DECLS)` shell:
+  - `:type-sig NAMES TYPE` — comma-separated multi-name support
+  - `:fun-clause NAME APATS BODY` — patterns for args, body via existing expr
+  - `:pat-bind PAT BODY` — top-level pattern bindings like `(a, b) = pair`
+  - `:data NAME TVARS CONS` with `:con-def CNAME FIELDS` for nullary and
+    multi-arg constructors, including recursive references
+  - `:type-syn NAME TVARS TYPE`, `:newtype NAME TVARS CNAME FIELD`
+  - `:fixity ASSOC PREC OPS` — assoc one of `"l"`/`"r"`/`"n"`, default prec 9,
+    comma-separated operator names, including backtick-quoted varids.
+  Sig vs fun-clause disambiguated by a paren-balanced top-level scan for
+  `::` before the next `;`/`}` (`hk-has-top-dcolon?`). 24 new tests in
+  `lib/haskell/tests/parser-decls.sx` cover all decl forms, signatures with
+  application / tuples / lists / right-assoc arrows, nullary and recursive
+  data types, multi-clause functions, and a mixed program with data + type-
+  synonym + signature + two function clauses. Not yet: guards, where
+  clauses, module header, imports, deriving, contexts, GADTs. 162/162 green.
+
+- **2026-04-24** — Phase 1: full patterns. Added `as` patterns
+  (`name@apat` → `(:p-as NAME PAT)`), lazy patterns (`~apat` →
+  `(:p-lazy PAT)`), negative literal patterns (`-N` / `-F` resolving
+  eagerly in the parser so downstream passes see a plain `(:p-int -1)`),
+  and infix constructor patterns via a right-associative single-band
+  layer on top of `hk-parse-pat-lhs` for any `consym` or reservedop `:`
+  (so `x : xs` parses as `(:p-con ":" [x, xs])`, `a :+: b` likewise).
+  Extended `hk-apat-start?` with `-` and `~` so the pattern-argument
+  loops in lambdas and constructor applications pick these up.
+  Lambdas now parse apat parameters instead of bare varids — so the
+  `:lambda` AST is `(:lambda APATS BODY)` with apats as pattern nodes.
+  `hk-parse-bind` became a plain `pat = expr` form, so `:bind` now has
+  a pattern LHS throughout (simple `x = 1` → `(:bind (:p-var "x") …)`);
+  this picks up `let (x, y) = pair in …` and `let Just x = m in x`
+  automatically, and flows through `do`-notation lets. Eight existing
+  tests updated to the pattern-flavoured AST. Also fixed a pragmatic
+  layout issue that surfaced in multi-line `let`s: when a layout-indent
+  would emit a spurious `;` just before an `in` token (because the
+  let block had already been closed by dedent), `hk-peek-next-reserved`
+  now lets the layout pass skip that indent and leave closing to the
+  existing `in` handler. 18 new tests in
+  `lib/haskell/tests/parser-patterns.sx` cover every pattern variant,
+  lambda with mixed apats, let pattern-bindings (tuple / constructor /
+  cons), and do-bind with a tuple pattern. 138/138 green.
+
+- **2026-04-24** — Phase 1: `case … of` and `do`-notation parsers. Added `hk-parse-case`
+  / `hk-parse-alt`, `hk-parse-do` / `hk-parse-do-stmt` / `hk-parse-do-let`, plus the
+  minimal pattern language needed to make arms and binds meaningful:
+  `hk-parse-apat` (var, wildcard `_`, int/float/string/char literal, 0-arity
+  conid/qconid, paren+tuple, list) and `hk-parse-pat` (conid applied to
+  apats greedily). AST nodes: `:case SCRUT ALTS`, `:alt PAT BODY`, `:do STMTS`
+  with stmts `:do-expr E` / `:do-bind PAT E` / `:do-let BINDS`, and pattern
+  tags `:p-wild` / `:p-int` / `:p-float` / `:p-string` / `:p-char` / `:p-var`
+  / `:p-con NAME ARGS` / `:p-tuple` / `:p-list`. `do`-stmts disambiguate
+  `pat <- e` vs bare expression with a forward paren/bracket/brace-balanced
+  scan for `<-` before the next `;`/`}` — no backtracking, no AST rewrite.
+  `case` and `do` accept both implicit (`vlbrace`/`vsemi`/`vrbrace`) and
+  explicit braces. Added to `hk-parse-lexp` so they participate fully in
+  operator-precedence expressions. 19 new tests in
+  `lib/haskell/tests/parser-case-do.sx` cover every pattern variant,
+  explicit-brace `case`, expression scrutinees, do with bind/let/expr,
+  multi-binding `let` in `do`, constructor patterns in binds, and
+  `case`/`do` nested inside `let` and lambda. The full pattern item (as
+  patterns, negative literals, `~` lazy, lambda/let pattern extension)
+  remains a separate sub-item. 119/119 green.
+
+- **2026-04-24** — Phase 1: expression parser (`lib/haskell/parser.sx`, ~380 lines).
+  Pratt-style precedence climbing against a Haskell-98-default op table (24
+  operators across precedence 0–9, left/right/non assoc, default infixl 9 for
+  anything unlisted). Supports literals (int/float/string/char), varid/conid
+  (qualified variants folded into `:var` / `:con`), parens / unit / tuples,
+  list literals, ranges `[a..b]` and `[a,b..c]`, left-associative application,
+  unary `-`, backtick operators (`x \`mod\` 3`), lambdas, `if-then-else`, and
+  `let … in` consuming both virtual and explicit braces. AST uses keyword
+  tags (`:var`, `:op`, `:lambda`, `:let`, `:bind`, `:tuple`, `:range`,
+  `:range-step`, `:app`, `:neg`, `:if`, `:list`, `:int`, `:float`, `:string`,
+  `:char`, `:con`). The parser skips a leading `vlbrace` / `lbrace` so it can
+  be called on full post-layout output, and uses a `raise`-based error channel
+  with location-lite messages. 42 new tests in `lib/haskell/tests/parser-expr.sx`
+  cover literals, identifiers, parens/tuple/unit, list + range, app associativity,
+  operator precedence (mul over add, cons right-assoc, function-composition
+  right-assoc, `$` lowest), backtick ops, unary `-`, lambda multi-param,
+  `if` with infix condition, single- and multi-binding `let` (both implicit
+  and explicit braces), plus a few mixed nestings. 100/100 green.
+
+- **2026-04-24** — Phase 1: layout algorithm (`lib/haskell/layout.sx`, ~260 lines)
+  implementing Haskell 98 §10.3. Two-pass design: a pre-pass augments the raw
+  token stream with explicit `layout-open` / `layout-indent` markers (suppressing
+  `<n>` when `{n}` already applies, per note 3), then an L pass consumes the
+  augmented stream against a stack of implicit/explicit layout contexts and
+  emits `vlbrace` / `vsemi` / `vrbrace` tokens; newlines are dropped. Supports
+  the initial module-level implicit open (skipped when the first token is
+  `module` or `{`), the four layout keywords (`let`/`where`/`do`/`of`), explicit
+  braces disabling layout, dedent closing nested implicit blocks while also
+  emitting `vsemi` at the enclosing level, and the pragmatic single-line
+  `let … in` rule (emit `}` when `in` meets an implicit let). 15 new tests
+  in `lib/haskell/tests/layout.sx` cover module-start, do/let/where/case/of,
+  explicit braces, multi-level dedent, line continuation, and EOF close-down.
+  Shared test helpers moved to `lib/haskell/testlib.sx` so both test files
+  can share one `hk-test`. `test.sh` preloads tokenizer + layout + testlib.
+  58/58 green.
+
 - **2026-04-24** — Phase 1: Haskell 98 tokenizer (`lib/haskell/tokenizer.sx`, 490 lines)
   covering idents (lower/upper/qvarid/qconid), 23 reserved words, 11 reserved ops,
   varsym/consym operator chains, integer/hex/octal/float literals incl. exponent

plans/prolog-on-sx.md

@@ -39,36 +39,36 @@ Representation choices (finalise in phase 1, document here):
 ## Roadmap
 
 ### Phase 1 — tokenizer + term parser (no operator table)
-- [x] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, punct `( ) , . [ ] | ! :-`, comments (`%`, `/* */`)
+- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, punct `( ) , . [ ] | ! :-`, comments (`%`, `/* */`)
-- [x] Parser: clauses `head :- body.` and facts `head.`; terms `atom | Var | number | compound(args) | [list,sugar]`
+- [ ] Parser: clauses `head :- body.` and facts `head.`; terms `atom | Var | number | compound(args) | [list,sugar]`
-- [x] **Skip for phase 1:** operator table. `X is Y + 1` must be written `is(X, '+'(Y, 1))`; `=` written `=(X, Y)`. Operators land in phase 4.
+- [ ] **Skip for phase 1:** operator table. `X is Y + 1` must be written `is(X, '+'(Y, 1))`; `=` written `=(X, Y)`. Operators land in phase 4.
-- [x] Unit tests in `lib/prolog/tests/parse.sx` — 25 pass
+- [ ] Unit tests in `lib/prolog/tests/parse.sx`
 
 ### Phase 2 — unification + trail
-- [x] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!`
+- [ ] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!`
-- [x] Occurs-check off by default, exposed as flag
+- [ ] Occurs-check off by default, exposed as flag
-- [x] 30+ unification tests in `lib/prolog/tests/unify.sx`: atoms, vars, compounds, lists, cyclic (no-occurs-check), mutual occurs — 47 pass
+- [ ] 30+ unification tests in `lib/prolog/tests/unify.sx`: atoms, vars, compounds, lists, cyclic (no-occurs-check), mutual occurs
 
 ### Phase 3 — clause DB + DFS solver + cut + first classic programs
-- [x] Clause DB: `"functor/arity" → list-of-clauses`, loader inserts — `pl-mk-db` / `pl-db-add!` / `pl-db-load!` / `pl-db-lookup` / `pl-db-lookup-goal`, 14 tests in `tests/clausedb.sx`
+- [ ] Clause DB: `"functor/arity" → list-of-clauses`, loader inserts
-- [x] Solver: DFS with choice points backed by delimited continuations (`lib/callcc.sx`). On goal entry, capture; per matching clause, unify head + recurse body; on failure, undo trail, try next — first cut: trail-based undo + CPS k (no shift/reset yet, per briefing gotcha). Built-ins so far: `true/0`, `fail/0`, `=/2`, `,/2`. Refactor to delimited conts later.
+- [ ] Solver: DFS with choice points backed by delimited continuations (`lib/callcc.sx`). On goal entry, capture; per matching clause, unify head + recurse body; on failure, undo trail, try next
-- [x] Cut (`!`): cut barrier at current choice-point frame; collapse all up to barrier — two-cut-box scheme: each `pl-solve-user!` creates a fresh inner-cut-box (set by `!` in this predicate's body) AND snapshots the outer-cut-box state on entry. After body fails, abandon clause alternatives if (a) inner was set or (b) outer transitioned false→true during this call. Lets post-cut goals backtrack normally while blocking pre-cut alternatives. 6 cut tests cover bare cut, clause-commit, choice-commit, cut+fail, post-cut backtracking, nested-cut isolation.
+- [ ] Cut (`!`): cut barrier at current choice-point frame; collapse all up to barrier
-- [x] Built-ins: `=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2` inside `;`, `call/1`, `write/1`, `nl/0` — all 11 done. `write/1` and `nl/0` use a global `pl-output-buffer` string + `pl-output-clear!` for testability; `pl-format-term` walks deep then renders atoms/nums/strs/compounds/vars (var → `_<id>`). Note: cut-transparency via `;` not testable yet without operator support — `;(,(a,!), b)` parser-rejects because `,` is body-operator-only; revisit in phase 4.
+- [ ] Built-ins: `=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2` inside `;`, `call/1`, `write/1`, `nl/0`
-- [x] Arithmetic `is/2` with `+ - * / mod abs` — `pl-eval-arith` walks deep, recurses on compounds, dispatches on functor; binary `+ - * / mod`, binary AND unary `-`, unary `abs`. `is/2` evaluates RHS, wraps as `("num" v)`, unifies via `pl-solve-eq!`. 11 tests cover each op + nested + ground LHS match/mismatch + bound-var-on-RHS chain.
+- [ ] Arithmetic `is/2` with `+ - * / mod abs`
 - [ ] Classic programs in `lib/prolog/tests/programs/`:
-  - [x] `append.pl` — list append (with backtracking) — `lib/prolog/tests/programs/append.{pl,sx}`. 6 tests cover: build (`append([], L, X)`, `append([1,2], [3,4], X)`), check ground match/mismatch, full split-backtracking (`append(X, Y, [1,2,3])` → 4 solutions), single-deduce (`append(X, [3], [1,2,3])` → X=[1,2]).
+  - [ ] `append.pl` — list append (with backtracking)
-  - [x] `reverse.pl` — naive reverse — `lib/prolog/tests/programs/reverse.{pl,sx}`. Naive reverse via append: `reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R)`. 6 tests cover empty, singleton, 3-list, 4-atom-list, ground match, ground mismatch.
+  - [ ] `reverse.pl` — naive reverse
-  - [x] `member.pl` — generate all solutions via backtracking — `lib/prolog/tests/programs/member.{pl,sx}`. Classic 2-clause `member(X, [X|_])` + `member(X, [_|T]) :- member(X, T)`. 7 tests cover bound-element hit/miss, empty list, generator (count = list length), first-solution binding, duplicate matches counted twice, anonymous head-cell unification.
+  - [ ] `member.pl` — generate all solutions via backtracking
-  - [x] `nqueens.pl` — 8-queens — `lib/prolog/tests/programs/nqueens.{pl,sx}`. Permute-and-test formulation: `queens(L, Qs) :- permute(L, Qs), safe(Qs)` + `select` + `safe` + `no_attack`. Tested at N=1 (1), N=2 (0), N=3 (0), N=4 (2), N=5 (10) plus first-solution check at N=4 = `[2, 4, 1, 3]`. N=8 omitted — interpreter is too slow (40320 perms); add once compiled clauses or constraint-style placement land. `range/3` skipped pending arithmetic-comparison built-ins (`>/2` etc.).
+  - [ ] `nqueens.pl` — 8-queens
-  - [x] `family.pl` — facts + rules (parent/ancestor) — `lib/prolog/tests/programs/family.{pl,sx}`. 5 parent facts + male/female + derived `father`/`mother`/`ancestor`/`sibling`. 10 tests cover direct facts, fact count, transitive ancestor through 3 generations, descendant counting, gender-restricted father/mother, sibling via shared parent + `\=`.
+  - [ ] `family.pl` — facts + rules (parent/ancestor)
-- [x] `lib/prolog/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` — bash script feeds load + eval epoch script to sx_server, parses each suite's `{:failed N :passed N :total N :failures (...)}` line, writes JSON (machine) + MD (human) scoreboards. Exit non-zero on any failure. `SX_SERVER` env var overrides binary path. First scoreboard: 183 / 183.
+- [ ] `lib/prolog/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
-- [x] Target: all 5 classic programs passing — append (6) + reverse (6) + member (7) + nqueens (6) + family (10) = 35 program tests, all green. Phase 3 architecturally complete bar the conformance harness/scoreboard.
+- [ ] Target: all 5 classic programs passing
 
 ### Phase 4 — operator table + more built-ins (next run)
-- [x] Operator table parsing (prefix/infix/postfix, precedence, assoc) — `pl-op-table` (15 entries: `, ; -> = \= is < > =< >= + - * / mod`); precedence-climbing parser via `pp-parse-primary` + `pp-parse-term-prec` + `pp-parse-op-rhs`. Parens override precedence. Args inside compounds parsed at 999 so `,` stays as separator. xfx/xfy/yfx supported; prefix/postfix deferred (so `-5` still tokenises as bare atom + num as before). Comparison built-ins `</2 >/2 =</2 >=/2` added. New `tests/operators.sx` 19 tests cover assoc/precedence/parens + solver via infix.
+- [ ] Operator table parsing (prefix/infix/postfix, precedence, assoc)
-- [x] `assert/1`, `asserta/1`, `assertz/1`, `retract/1` — `assert` aliases `assertz`. Helpers `pl-rt-to-ast` (deep-walk + replace runtime vars with `_G<id>` parse markers) + `pl-build-clause` (detect `:-` head). `assertz` uses `pl-db-add!`; `asserta` uses new `pl-db-prepend!`. `retract` walks goal, looks up by functor/arity, tries each clause via unification, removes first match by index (`pl-list-without`). 11 tests in `tests/dynamic.sx`. Rule-asserts deferred — `:-` not in op table yet, so only fact-shaped clauses for now.
+- [ ] `assert/1`, `asserta/1`, `assertz/1`, `retract/1`
-- [x] `findall/3`, `bagof/3`, `setof/3` — shared `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template (via `pl-deep-copy` with var-map for shared-var preservation) on each success, returns false to backtrack, then restores trail. `findall` always succeeds with a (possibly empty) list. `bagof` fails on empty. `setof` builds a string-keyed dict via `pl-format-term` for sort+dedupe (via `keys` + `sort`), fails on empty. Existential `^` deferred (operator). 11 tests in `tests/findall.sx`.
+- [ ] `findall/3`, `bagof/3`, `setof/3`
-- [x] `copy_term/2`, `functor/3`, `arg/3`, `=../2` — `copy_term/2` reuses `pl-deep-copy` with a fresh var-map (preserves source aliasing). `functor/3` handles 4 modes: compound→{name, arity}, atom→{atom, 0}, num→{num, 0}, var with ground name+arity→constructed term (`pl-make-fresh-args` for compound case). `arg/3` extracts 1-indexed arg from compound. **`=../2` deferred** — the tokenizer treats `.` as the clause terminator unconditionally, so `=..` lexes as `=` + `.` + `.`; needs special-case lex (or surface syntax via a different name). 14 tests in `tests/term_inspect.sx`.
+- [ ] `copy_term/2`, `functor/3`, `arg/3`, `=../2`
 - [ ] String/atom predicates
 
 ### Phase 5 — Hyperscript integration
@@ -88,24 +88,6 @@ Representation choices (finalise in phase 1, document here):
 
 _Newest first. Agent appends on every commit._
 
-- 2026-04-25 — `copy_term/2` + `functor/3` + `arg/3` (term inspection). `copy_term` is a one-line dispatch to existing `pl-deep-copy`. `functor/3` is bidirectional — decomposes a bound compound/atom/num into name+arity OR constructs from ground name+arity (atom+positive-arity → compound with N anonymous fresh args via `pl-make-fresh-args`; arity 0 → atom/num). `arg/3` extracts 1-indexed arg with bounds-fail. New helper `pl-solve-eq2!` for paired-unification with shared trail-undo. 14 tests in `tests/term_inspect.sx`. Total **238** (+14). `=..` deferred — `.` always tokenizes as clause terminator; needs special lexer case.
-- 2026-04-25 — `findall/3` + `bagof/3` + `setof/3`. Shared collector `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template per success (`pl-deep-copy` walks term, allocates fresh runtime vars via shared var-map so co-occurrences keep aliasing), returns false to keep backtracking, then `pl-trail-undo-to!` to clean up. `findall` always builds a list. `bagof` fails on empty. `setof` uses a `pl-format-term`-keyed dict + SX `sort` for dedupe + ordering. New `tests/findall.sx` 11 tests. Total **224** (+11). Existential `^` deferred — needs operator.
-- 2026-04-25 — Dynamic clauses: `assert/1`, `assertz/1`, `asserta/1`, `retract/1`. New helpers `pl-rt-to-ast` (deep-walk runtime term → parse-AST, mapping unbound runtime vars to `_G<id>` markers so `pl-instantiate-fresh` produces fresh vars per call) + `pl-build-clause` + `pl-db-prepend!` + `pl-list-without`. `retract` keeps runtime vars (so the caller's vars get bound), walks head for the functor/arity key, tries each stored clause via `pl-unify!`, removes the first match by index. 11 tests in `tests/dynamic.sx`; conformance script gained dynamic row. Total **213** (+11). Rule-form asserts (`(H :- B)`) deferred until `:-` is in the op table.
-- 2026-04-25 — Phase 4 starts: operator-table parsing. Parser rewrite uses precedence climbing (xfx/xfy/yfx); 15-op table covers control (`, ; ->`), comparison (`= \\= is < > =< >=`), arithmetic (`+ - * / mod`). Parens override. Backwards-compatible: prefix-syntax compounds (`=(X, Y)`, `+(2, 3)`) still parse as before; existing 183 tests untouched. Added comparison built-ins `</2 >/2 =</2 >=/2` to runtime (eval both sides, compare). New `tests/operators.sx` 19 tests; conformance script gained an operators row. Total **202** (+19). Prefix/postfix deferred — `-5` keeps old bare-atom semantics.
-- 2026-04-25 — Conformance harness landed. `lib/prolog/conformance.sh` runs all 9 suites in one sx_server epoch, parses the `{:failed/:passed/:total/:failures}` summary lines, and writes `scoreboard.json` + `scoreboard.md`. `SX_SERVER` env var overrides the binary path; default points at the main-repo build. Phase 3 fully complete: 183 / 183 passing across parse/unify/clausedb/solve/append/reverse/member/nqueens/family.
-- 2026-04-25 — `family.pl` fifth classic program — completes the 5-program target. 5-fact pedigree + male/female + derived father/mother/ancestor/sibling. 10 tests cover fact lookup + count, transitive ancestor through 3 generations, descendant counting (5), gender-restricted derivations, sibling via shared parent guarded by `\=`. Total 183 (+10). All 5 classic programs ticked; Phase 3 needs only conformance harness + scoreboard left.
-- 2026-04-25 — `nqueens.pl` fourth classic program. Permute-and-test variant exercises every Phase-3 feature: lists with `[H|T]` cons sugar, multi-clause backtracking, recursive `permute`/`select`/`safe`/`no_attack`, `is/2` arithmetic on diagonals, `\=/2` for diagonal-conflict check. 6 tests at N ∈ {1,2,3,4,5} with expected counts {1,0,0,2,10} + first-solution `[2,4,1,3]`. N=5 takes ~30s (120 perms × safe-check); N=8 omitted as it would be ~thousands of seconds. Total 173 (+6).
-- 2026-04-25 — `member.pl` third classic program. Standard 2-clause definition; 7 tests cover bound-element hit/miss, empty-list fail, generator-count = list length, first-solution binding (X=11), duplicate elements matched twice on backtrack, anonymous-head unification (`member(a, [X, b, c])` binds X=a). Total 167 (+7).
-- 2026-04-25 — `reverse.pl` second classic program. Naive reverse defined via append. 6 tests (empty/singleton/3-list/4-atom-list/ground match/ground mismatch). Confirms the solver handles non-trivial recursive composition: `reverse([1,2,3], R)` recurses to depth 3 then unwinds via 3 nested `append`s. Total 160 (+6).
-- 2026-04-25 — `append.pl` first classic program. `lib/prolog/tests/programs/append.pl` is the canonical 2-clause source; `append.sx` embeds the source as a string (no file-read primitive in SX yet) and runs 6 tests covering build, check, full split-backtrack (4 solutions), and deduction modes. Helpers `pl-ap-list-to-sx` / `pl-ap-term-to-sx` convert deep-walked Prolog lists (`("compound" "." (h t))` / `("atom" "[]")`) to SX lists for structural assertion. Total 154 (+6).
-- 2026-04-25 — `is/2` arithmetic landed. `pl-eval-arith` recursively evaluates ground RHS expressions (binary `+ - * /`, `mod`; binary+unary `-`; unary `abs`); `is/2` wraps the value as `("num" v)` and unifies via `pl-solve-eq!`, so it works in all three modes — bind unbound LHS, check ground LHS for equality, propagate from earlier var bindings on RHS. 11 tests, total 148 (+11). Without operator support, expressions must be written prefix: `is(X, +(2, *(3, 4)))`.
-- 2026-04-25 — `write/1` + `nl/0` landed using global string buffer (`pl-output-buffer` + `pl-output-clear!` + `pl-output-write!`). `pl-format-term` walks deep + dispatches on atom/num/str/compound/var; `pl-format-args` recursively comma-joins. 7 new tests cover atom/num/compound formatting, conjunction order, var-walk, and `nl`. Built-ins box (`=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2`, `call/1`, `write/1`, `nl/0`) now ticked. Total 137 (+7).
-- 2026-04-25 — `->/2` if-then-else landed (both `;(->(C,T), E)` and standalone `->(C, T)` ≡ `(C -> T ; fail)`). `pl-solve-or!` now special-cases `->` in left arg → `pl-solve-if-then-else!`. Cond runs in a fresh local cut-box (ISO opacity for cut inside cond). Then-branch can backtrack, else-branch can backtrack, but cond commits to first solution. 9 new tests covering both forms, both branches, binding visibility, cond-commit, then-backtrack, else-backtrack. Total 130 (+9).
-- 2026-04-25 — Built-ins `\=/2`, `;/2`, `call/1` landed. `pl-solve-not-eq!` (try unify, always undo, succeed iff unify failed). `pl-solve-or!` (try left, on failure check cut and only try right if not cut). `call/1` opens a fresh inner cut-box (ISO opacity: cut inside `call(G)` commits G, not caller). 11 new tests in `tests/solve.sx` cover atoms+vars for `\=`, both branches + count for `;`, and `call/1` against atoms / compounds / bound goal vars. Total 121 (+11). Box not yet ticked — `->/2`, `write/1`, `nl/0` still pending.
-- 2026-04-25 — Cut (`!/0`) landed. `pl-cut?` predicate; solver functions all take a `cut-box`; `pl-solve-user!` creates a fresh inner-cut-box and snapshots `outer-was-cut`; `pl-try-clauses!` abandons alternatives when inner.cut OR (outer.cut transitioned false→true during this call). 6 new cut tests in `tests/solve.sx` covering bare cut, clause-commit, choice-commit, cut+fail blocks alt clauses, post-cut goal backtracks freely, inner cut isolation. Total 110 (+6).
-- 2026-04-25 — Phase 3 DFS solver landed (CPS, trail-based backtracking; delimited conts deferred). `pl-solve!` + `pl-solve-eq!` + `pl-solve-user!` + `pl-try-clauses!` + `pl-solve-once!` + `pl-solve-count!` in runtime.sx. Built-ins: `true/0`, `fail/0`, `=/2`, `,/2`. New `tests/solve.sx` 18/18 green covers atomic goals, =, conjunction, fact lookup, multi-solution count, recursive ancestor rule, trail-undo verification. Bug fix: `pl-instantiate` had no `("clause" h b)` case → vars in rule head/body were never instantiated, so rule resolution silently failed against runtime-var goals. Added clause case to recurse with shared var-env. Total 104 (+18).
-- 2026-04-24 — Phase 3 clause DB landed: `pl-mk-db` + `pl-head-key` / `pl-clause-key` / `pl-goal-key` + `pl-db-add!` / `pl-db-load!` / `pl-db-lookup` / `pl-db-lookup-goal` in runtime.sx. New `tests/clausedb.sx` 14/14 green. Total 86 (+14). Loader preserves declaration order (append!).
-- 2026-04-24 — Verified phase 1+2 already implemented on loops/prolog: `pl-parse-tests-run!` 25/25, `pl-unify-tests-run!` 47/47 (72 total). Ticked phase 1+2 boxes.
 - _(awaiting phase 1)_
 
 ## Blockers