haskell: Phase 16 — exception handling (catch/try/throwIO/evaluate/handle/throw)

hk-bind-exceptions! in eval.sx registers throwIO, throw, evaluate, catch,
try, handle, displayException. SomeException constructor pre-registered
in runtime.sx (arity 1, type SomeException).

throwIO and the existing error primitive both raise via SX `raise` with a
uniform "hk-error: msg" string. catch/try/handle parse it back into a
SomeException via hk-exception-of, which strips nested
'Unhandled exception: "..."' host wraps (CEK's host_error formatter) and
the "hk-error: " prefix.

catch and handle evaluate the handler outside the guard scope (build an
"ok"/"exn" outcome tag inside guard, then dispatch outside) so that a
re-throw from the handler propagates past this catch — matching Haskell
semantics rather than infinite-looping in the same guard.

14 unit tests in tests/exceptions.sx (catch success, catch error, try
Right/Left, handle, throwIO + catch/try, evaluate, nested catch, do-bind
through catch, branch on try result, IORef-mutating handler).

Conformance: safediv.hs (8/8) and trycatch.hs (8/8). Scoreboard now
285/285 tests, 36/36 programs.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>

lib/haskell/eval.sx

@@ -790,6 +790,7 @@
       (dict-set! env "rem" (hk-make-binop-builtin "rem" "rem"))
       (dict-set! env "quot" (hk-make-binop-builtin "quot" "quot"))
       (dict-set! env "show" (hk-mk-lazy-builtin "show" hk-show-val 1))
+      (hk-bind-exceptions! env)
       (hk-load-into! env hk-prelude-src)
       (begin
         (dict-set!
@@ -1364,6 +1365,148 @@
                   (list "IO" (list "Tuple")))))
             2))))))
 
+(define
+  hk-strip-prefix
+  (fn
+    (s prefix)
+    (let ((pl (string-length prefix)) (sl (string-length s)))
+      (cond
+        ((and (>= sl pl) (= (substr s 0 pl) prefix))
+          (substr s pl (- sl pl)))
+        (:else s)))))
+
+(define
+  hk-strip-quotes-once
+  (fn
+    (s)
+    (let ((sl (string-length s)))
+      (cond
+        ((and (>= sl 2)
+              (= (substr s 0 1) "\"")
+              (= (substr s (- sl 1) 1) "\""))
+          (substr s 1 (- sl 2)))
+        ((and (>= sl 4)
+              (= (substr s 0 2) "\\\"")
+              (= (substr s (- sl 2) 2) "\\\""))
+          (substr s 2 (- sl 4)))
+        (:else s)))))
+
+(define
+  hk-strip-host-wrap-once
+  (fn
+    (s)
+    (let ((s1 (hk-strip-prefix s "Unhandled exception: ")))
+      (cond
+        ((= s1 s) s)
+        (:else (hk-strip-quotes-once s1))))))
+
+(define
+  hk-strip-host-wrap
+  (fn
+    (s)
+    (let ((s1 (hk-strip-host-wrap-once s)))
+      (cond
+        ((= s1 s) s)
+        (:else (hk-strip-host-wrap s1))))))
+
+(define
+  hk-exception-msg
+  (fn
+    (v)
+    (let ((fv (hk-deep-force v)))
+      (cond
+        ((string? fv) fv)
+        ((and (list? fv) (not (empty? fv))
+              (= (first fv) "SomeException"))
+          (let ((m (nth fv 1)))
+            (if (string? m) m (str m))))
+        (:else (str fv))))))
+
+(define
+  hk-exception-of
+  (fn
+    (e)
+    (cond
+      ((and (list? e) (not (empty? e))
+            (= (first e) "hk-haskell-exception"))
+        (nth e 1))
+      ((string? e)
+        (let ((s (hk-strip-host-wrap e)))
+          (let ((s2 (hk-strip-prefix s "hk-error: ")))
+            (list "SomeException" s2))))
+      (:else (list "SomeException" (str e))))))
+
+(define
+  hk-bind-exceptions!
+  (fn
+    (env)
+    (begin
+      (dict-set! env "throwIO"
+        (hk-mk-lazy-builtin "throwIO"
+          (fn (e) (raise (str "hk-error: " (hk-exception-msg e))))
+          1))
+      (dict-set! env "throw"
+        (hk-mk-lazy-builtin "throw"
+          (fn (e) (raise (str "hk-error: " (hk-exception-msg e))))
+          1))
+      (dict-set! env "evaluate"
+        (hk-mk-lazy-builtin "evaluate"
+          (fn (x)
+            (let ((v (hk-deep-force x)))
+              (list "IO" v)))
+          1))
+      (dict-set! env "catch"
+        (hk-mk-lazy-builtin "catch"
+          (fn (action handler)
+            (let
+              ((outcome
+                 (guard
+                   (e (true (list "exn" e)))
+                   (list "ok" (hk-force action)))))
+              (cond
+                ((= (first outcome) "ok") (nth outcome 1))
+                (:else
+                  (let ((some-ex (hk-exception-of (nth outcome 1))))
+                    (hk-force (hk-apply (hk-force handler) some-ex)))))))
+          2))
+      (dict-set! env "try"
+        (hk-mk-lazy-builtin "try"
+          (fn (action)
+            (guard
+              (e (true
+                   (list "IO" (list "Left" (hk-exception-of e)))))
+              (let ((io-val (hk-force action)))
+                (cond
+                  ((and (list? io-val) (= (first io-val) "IO"))
+                    (list "IO" (list "Right" (nth io-val 1))))
+                  (:else
+                    (raise "try: action did not produce IO"))))))
+          1))
+      (dict-set! env "handle"
+        (hk-mk-lazy-builtin "handle"
+          (fn (handler action)
+            (let
+              ((outcome
+                 (guard
+                   (e (true (list "exn" e)))
+                   (list "ok" (hk-force action)))))
+              (cond
+                ((= (first outcome) "ok") (nth outcome 1))
+                (:else
+                  (let ((some-ex (hk-exception-of (nth outcome 1))))
+                    (hk-force (hk-apply (hk-force handler) some-ex)))))))
+          2))
+      (dict-set! env "displayException"
+        (hk-mk-lazy-builtin "displayException"
+          (fn (e)
+            (let ((v (hk-force e)))
+              (cond
+                ((and (list? v) (not (empty? v))
+                      (= (first v) "SomeException"))
+                  (hk-deep-force (nth v 1)))
+                (:else (str v)))))
+          1)))))
+
 (define
   hk-bind-decls!
   (fn