haskell: strict evaluator + 38 eval tests, Phase 2 complete (329/329)

lib/haskell/eval.sx

@@ -0,0 +1,530 @@
+;; 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)))
+
+;; ── 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 :collected (list)}))
+
+;; ── Apply a function value to one argument ──────────────────
+(define
+  hk-apply
+  (fn
+    (f arg)
+    (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 (apply (get b "fn") 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-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-eval (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 "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-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-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)
+    (let
+      ((lv (hk-eval left env)) (rv (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")))))
+
+(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 ────────────────────────────
+(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))
+      env)))
+
+(define
+  hk-bind-decls!
+  (fn
+    (env decls)
+    (let ((groups (dict)) (pat-binds (list)))
+      ;; Pass 1: collect fun-clause groups by name; collect pat-binds
+      ;; in source order. Pre-seed env so any name can already be
+      ;; looked up by closures built in pass 2.
+      (for-each
+        (fn (d)
+          (cond
+            ((= (first d) "fun-clause")
+              (let
+                ((name (nth d 1)))
+                (dict-set!
+                  groups
+                  name
+                  (append
+                    (if
+                      (has-key? groups name)
+                      (get groups name)
+                      (list))
+                    (list (list (nth d 2) (nth d 3)))))
+                (when
+                  (not (has-key? env name))
+                  (dict-set! env name nil))))
+            ((or (= (first d) "bind") (= (first d) "pat-bind"))
+              (append! pat-binds d))
+            (:else nil)))
+        decls)
+      ;; Pass 2: install multifuns for arity > 0; mark 0-arity for
+      ;; pass 3. The mutable env means recursive references work.
+      (let ((zero-arity (list)))
+        (for-each
+          (fn (name)
+            (let ((clauses (get groups name)))
+              (let ((arity (len (first (first clauses)))))
+                (cond
+                  ((> arity 0)
+                    (dict-set!
+                      env
+                      name
+                      (hk-mk-multifun arity clauses env)))
+                  (:else (append! zero-arity name))))))
+          (keys groups))
+        ;; Pass 3: evaluate 0-arity bodies and pat-binds.
+        (for-each
+          (fn (name)
+            (let ((clauses (get groups name)))
+              (dict-set!
+                env
+                name
+                (hk-eval (first (rest (first clauses))) env))))
+          zero-arity)
+        (for-each
+          (fn (d)
+            (let ((pat (nth d 1)) (body (nth d 2)))
+              (let ((val (hk-eval body env)))
+                (let ((res (hk-match pat val env)))
+                  (cond
+                    ((nil? res)
+                      (raise "top-level pattern bind failure"))
+                    (:else (hk-extend-env-with-match! env res)))))))
+          pat-binds))
+      env)))
+
+(define
+  hk-eval-program
+  (fn
+    (ast)
+    (cond
+      ((nil? ast) (raise "eval-program: nil ast"))
+      ((not (list? ast)) (raise "eval-program: not a list"))
+      (:else
+        (do
+          (hk-register-program! ast)
+          (let ((env (hk-init-env)))
+            (let
+              ((decls
+                  (cond
+                    ((= (first ast) "program") (nth ast 1))
+                    ((= (first ast) "module") (nth ast 4))
+                    (:else (raise "eval-program: bad shape")))))
+              (hk-bind-decls! env decls))))))))
+
+;; ── Source-level convenience ────────────────────────────────
+(define
+  hk-run
+  (fn
+    (src)
+    (let ((env (hk-eval-program (hk-core src))))
+      (cond
+        ((has-key? env "main") (get env "main"))
+        (:else env)))))
+
+(define
+  hk-eval-expr-source
+  (fn
+    (src)
+    (hk-eval (hk-core-expr src) (hk-init-env))))

lib/haskell/runtime.sx

@@ -119,3 +119,12 @@
 (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

@@ -51,6 +51,7 @@ for FILE in "${FILES[@]}"; do
 (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")
@@ -92,6 +93,7 @@ EPOCHS
 (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")

lib/haskell/tests/eval.sx

@@ -0,0 +1,238 @@
+;; 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)
+    (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)
+
+;; ── 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}

plans/haskell-on-sx.md

@@ -71,8 +71,8 @@ Key mappings:
 - [x] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3)
 - [x] `data` declarations register constructors in runtime
 - [x] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested
-- [ ] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
-- [ ] 30+ eval tests in `lib/haskell/tests/eval.sx`
+- [x] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
+- [x] 30+ eval tests in `lib/haskell/tests/eval.sx`
 
 ### Phase 3 — laziness + classic programs
 - [ ] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
@@ -114,6 +114,36 @@ Key mappings:
 
 _Newest first._
 
+- **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`