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)))))