haskell: thunks + force, app args become lazy (+6 tests, 333/333)

lib/haskell/eval.sx

@@ -27,6 +27,49 @@
         (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
@@ -51,17 +94,18 @@
   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")))))
+    (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
@@ -154,7 +198,12 @@
       (cond
         ((< (len collected) arity)
           (assoc b "collected" collected))
-        (:else (apply (get b "fn") collected))))))
+        (:else
+          ;; Built-ins are strict in all their arguments. Force each
+          ;; collected thunk before invoking the underlying SX fn.
+          (apply
+            (get b "fn")
+            (map hk-force collected)))))))
 
 ;; ── Bool helpers (Bool values are tagged conses) ────────────
 (define
@@ -185,7 +234,8 @@
             ((= 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 "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")
@@ -193,7 +243,7 @@
             ((= tag "app")
               (hk-apply
                 (hk-eval (nth node 1) env)
-                (hk-eval (nth node 2) env)))
+                (hk-mk-thunk (nth node 2) env)))
             ((= tag "op")
               (hk-eval-op
                 (nth node 1)
@@ -239,7 +289,7 @@
   hk-eval-if
   (fn
     (node env)
-    (let ((cv (hk-eval (nth node 1) 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"))
@@ -309,7 +359,7 @@
   hk-eval-case
   (fn
     (scrut alts env)
-    (let ((sv (hk-eval scrut env)))
+    (let ((sv (hk-force (hk-eval scrut env))))
       (hk-try-alts alts sv env))))
 
 (define
@@ -334,7 +384,8 @@
   (fn
     (op left right env)
     (let
-      ((lv (hk-eval left env)) (rv (hk-eval right env)))
+      ((lv (hk-force (hk-eval left env)))
+        (rv (hk-force (hk-eval right env))))
       (hk-binop op lv rv))))
 
 (define
@@ -527,4 +578,4 @@
   hk-eval-expr-source
   (fn
     (src)
-    (hk-eval (hk-core-expr src) (hk-init-env))))
+    (hk-deep-force (hk-eval (hk-core-expr src) (hk-init-env)))))

lib/haskell/match.sx

@@ -60,6 +60,12 @@
 (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
@@ -73,65 +79,69 @@
           (cond
             ((= tag "p-wild") env)
             ((= tag "p-var") (assoc env (nth pat 1) val))
-            ((= tag "p-int")
-              (if
-                (and (number? val) (= val (nth pat 1)))
-                env
-                nil))
-            ((= tag "p-float")
-              (if
-                (and (number? val) (= val (nth pat 1)))
-                env
-                nil))
-            ((= tag "p-string")
-              (if
-                (and (string? val) (= val (nth pat 1)))
-                env
-                nil))
-            ((= tag "p-char")
-              (if
-                (and (string? val) (= val (nth pat 1)))
-                env
-                nil))
+            ((= 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)))))
-            ((= tag "p-lazy")
-              ;; Eager match for now; phase 3 wires laziness back in.
-              (hk-match (nth pat 1) val env))
-            ((= tag "p-con")
-              (let
-                ((pat-name (nth pat 1)) (pat-args (nth pat 2)))
+            (:else
+              (let ((fv (hk-force val)))
                 (cond
-                  ((not (hk-is-con-val? val)) nil)
-                  ((not (= (hk-val-con-name val) pat-name)) nil)
-                  (:else
+                  ((= 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
-                      ((val-args (hk-val-con-args val)))
+                      ((pat-name (nth pat 1)) (pat-args (nth pat 2)))
                       (cond
-                        ((not (= (len pat-args) (len val-args)))
+                        ((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 pat-args val-args env))))))))
-            ((= tag "p-tuple")
-              (let
-                ((items (nth pat 1)))
-                (cond
-                  ((not (hk-is-con-val? val)) nil)
-                  ((not (= (hk-val-con-name val) "Tuple")) nil)
-                  ((not (= (len (hk-val-con-args val)) (len items)))
-                    nil)
-                  (:else
-                    (hk-match-all
-                      items
-                      (hk-val-con-args val)
-                      env)))))
-            ((= tag "p-list")
-              (hk-match-list-pat (nth pat 1) val env))
-            (:else nil)))))))
+                          (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
@@ -151,32 +161,33 @@
   hk-match-list-pat
   (fn
     (items val env)
-    (cond
-      ((empty? items)
-        (if
-          (and
-            (hk-is-con-val? val)
-            (= (hk-val-con-name val) "[]"))
-          env
-          nil))
-      (:else
-        (cond
-          ((not (hk-is-con-val? val)) nil)
-          ((not (= (hk-val-con-name val) ":")) nil)
-          (:else
-            (let
-              ((args (hk-val-con-args val)))
+    (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
-                ((h (first args)) (t (first (rest args))))
+                ((args (hk-val-con-args fv)))
                 (let
-                  ((res (hk-match (first items) h env)))
-                  (cond
-                    ((nil? res) nil)
-                    (:else
-                      (hk-match-list-pat
-                        (rest items)
-                        t
-                        res))))))))))))
+                  ((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` —

lib/haskell/tests/eval.sx

@@ -6,7 +6,7 @@
   hk-prog-val
   (fn
     (src name)
-    (get (hk-eval-program (hk-core src)) name)))
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
 
 ;; ── Literals ──
 (hk-test "int literal" (hk-eval-expr-source "42") 42)
@@ -230,6 +230,46 @@
     "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"))

plans/haskell-on-sx.md

@@ -75,9 +75,9 @@ Key mappings:
 - [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>))`
-- [ ] `force` = SX eval-thunk-to-WHNF primitive
-- [ ] Pattern match forces scrutinee before matching
+- [x] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
+- [x] `force` = SX eval-thunk-to-WHNF primitive
+- [x] Pattern match forces scrutinee before matching
 - [ ] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream, sieve of Eratosthenes
 - [ ] `seq`, `deepseq` from Prelude
 - [ ] Do-notation for a stub `IO` monad (just threading, no real side effects yet)
@@ -114,6 +114,32 @@ Key mappings:
 
 _Newest first._
 
+- **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`,