haskell: Phase 9 — error builtin raises with hk-error: prefix (+2 tests, 57/57)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

lib/haskell/eval.sx

@@ -135,11 +135,9 @@
             (let
               ((env-after (hk-match p1 arg env)))
               (cond
-                ((nil? env-after)
-                  (raise "pattern match failure in lambda"))
+                ((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))))))))))
+                (:else (hk-mk-closure rest-p body env-after))))))))))
 
 (define
   hk-apply-multi
@@ -151,8 +149,7 @@
         (env (get mf "env"))
         (collected (append (get mf "collected") (list arg))))
       (cond
-        ((< (len collected) arity)
-          (assoc mf "collected" collected))
+        ((< (len collected) arity) (assoc mf "collected" collected))
         (:else (hk-dispatch-multi clauses collected env))))))
 
 (define
@@ -185,8 +182,7 @@
           ((res (hk-match (first pats) (first args) env)))
           (cond
             ((nil? res) nil)
-            (:else
-              (hk-match-args (rest pats) (rest args) res))))))))
+            (:else (hk-match-args (rest pats) (rest args) res))))))))
 
 (define
   hk-apply-con-partial
@@ -208,25 +204,16 @@
       ((arity (get b "arity"))
         (collected (append (get b "collected") (list arg))))
       (cond
-        ((< (len collected) arity)
-          (assoc b "collected" collected))
+        ((< (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)))))))))
+            (: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"))))
+  (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)))
@@ -250,8 +237,7 @@
             ((= 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 "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")
@@ -261,19 +247,12 @@
                 (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))
+              (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))))
+              (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))))
+              (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)))
@@ -286,25 +265,18 @@
                   (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)))
+                  :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 "'")))))))))
+            (:else (raise (str "eval: unknown node tag '" tag "'")))))))))
 
 (define
   hk-eval-var
@@ -319,18 +291,19 @@
   hk-eval-con-ref
   (fn
     (name)
-    (let ((arity (hk-con-arity 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)})))))
+        (:else {:args (list) :arity arity :type "con-partial" :name name})))))
 
 (define
   hk-eval-if
   (fn
     (node env)
-    (let ((cv (hk-force (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"))
@@ -351,37 +324,33 @@
   hk-eval-let-bind!
   (fn
     (b env)
-    (let ((tag (first b)))
+    (let
+      ((tag (first b)))
       (cond
         ((= tag "fun-clause")
           (let
-            ((name (nth b 1))
-              (pats (nth b 2))
-              (body (nth b 3)))
+            ((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))))))
+              ((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)))
+          (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)))))))
+                  ((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)
-    ;; Reuse hk-bind-decls! so multi-clause fun bindings in where/let
-    ;; are grouped into multifuns, enabling patterns like:
-    ;;   let { go 0 = [[]]; go k = [...] } in go n
-    (let ((new-env (hk-dict-copy env)))
+    (let
+      ((new-env (hk-dict-copy env)))
       (hk-bind-decls! new-env binds)
       (hk-eval body new-env))))
 
@@ -389,8 +358,7 @@
   hk-eval-case
   (fn
     (scrut alts env)
-    (let ((sv (hk-force (hk-eval scrut env))))
-      (hk-try-alts alts sv env))))
+    (let ((sv (hk-force (hk-eval scrut env)))) (hk-try-alts alts sv env))))
 
 (define
   hk-try-alts
@@ -414,14 +382,8 @@
   (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)))
+        (hk-mk-cons (hk-mk-thunk left env) (hk-mk-thunk right env)))
       (:else
         (let
           ((lv (hk-force (hk-eval left env)))
@@ -452,8 +414,7 @@
       ((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))))))
+      (:else (hk-mk-cons from (hk-build-range (+ from step) to step))))))
 
 (define
   hk-binop
@@ -495,33 +456,28 @@
   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)))
+    (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"))
+          (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)))
+    (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"))
+          (list :op op (list :var "__hk-sect-x") (list :var "__hk-sect-r"))
           cenv)))))
 
 ;; ── Top-level program evaluation ────────────────────────────
@@ -532,10 +488,7 @@
   hk-make-binop-builtin
   (fn
     (name op-name)
-    (hk-mk-builtin
-      name
-      (fn (a b) (hk-binop op-name a b))
-      2)))
+    (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
@@ -549,14 +502,11 @@
   hk-load-into!
   (fn
     (env src)
-    (let ((ast (hk-core 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)))))
+        ((decls (cond ((= (first ast) "program") (nth ast 1)) ((= (first ast) "module") (nth ast 4)) (:else (list)))))
         (hk-bind-decls! env decls)))))
 
 (define
@@ -635,10 +585,7 @@
       (dict-set!
         env
         "error"
-        (hk-mk-builtin
-          "error"
-          (fn (msg) (raise (str "*** Exception: " msg)))
-          1))
+        (hk-mk-builtin "error" (fn (msg) (raise (str "hk-error: " msg))) 1))
       (dict-set!
         env
         "not"

lib/haskell/tests/eval.sx

@@ -231,16 +231,30 @@
   1)
 
 ;; ── Laziness: app args evaluate only when forced ──
+(hk-test
+  "error builtin: raises with hk-error prefix"
+  (guard
+    (e (true (>= (index-of e "hk-error: boom") 0)))
+    (begin (hk-deep-force (hk-run "main = error \"boom\"")) false))
+  true)
+
+(hk-test
+  "error builtin: raises with computed message"
+  (guard
+    (e (true (>= (index-of e "hk-error: oops: 42") 0)))
+    (begin
+      (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)"))
+      false))
+  true)
+
 (hk-test
   "second arg never forced"
-  (hk-eval-expr-source
-    "(\\x y -> x) 1 (error \"never\")")
+  (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")
+  (hk-eval-expr-source "(\\x y -> y) (error \"never\") 99")
   99)
 
 (hk-test
@@ -251,28 +265,26 @@
 
 (hk-test
   "lazy: const drops its second argument"
-  (hk-prog-val
-    "const x y = x\nresult = const 5 (error \"boom\")"
-    "result")
+  (hk-prog-val "const x y = x\nresult = const 5 (error \"boom\")" "result")
   5)
 
+;; ── not / id built-ins ──
 (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}