From 0e53e88b02b1564056f91994e151963e4462d34e Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 23:22:21 +0000 Subject: [PATCH] haskell: thunks + force, app args become lazy (+6 tests, 333/333) --- lib/haskell/eval.sx | 87 ++++++++++++++++----- lib/haskell/match.sx | 155 ++++++++++++++++++++------------------ lib/haskell/tests/eval.sx | 42 ++++++++++- plans/haskell-on-sx.md | 32 +++++++- 4 files changed, 222 insertions(+), 94 deletions(-) diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index a8e882c7..9e62d568 100644 --- a/lib/haskell/eval.sx +++ b/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))))) diff --git a/lib/haskell/match.sx b/lib/haskell/match.sx index b98d164e..007d1358 100644 --- a/lib/haskell/match.sx +++ b/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` — diff --git a/lib/haskell/tests/eval.sx b/lib/haskell/tests/eval.sx index 5e0aeca5..560bd90f 100644 --- a/lib/haskell/tests/eval.sx +++ b/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")) diff --git a/plans/haskell-on-sx.md b/plans/haskell-on-sx.md index 5b7ccb80..165977d9 100644 --- a/plans/haskell-on-sx.md +++ b/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 () ))` -- [ ] `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 () ))` +- [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`,