diff --git a/lib/haskell/conformance.sh b/lib/haskell/conformance.sh index fa34edae..10252ae8 100755 --- a/lib/haskell/conformance.sh +++ b/lib/haskell/conformance.sh @@ -20,7 +20,7 @@ if [ ! -x "$SX_SERVER" ]; then fi fi -PROGRAMS=(fib sieve quicksort nqueens calculator collatz palindrome maybe fizzbuzz anagram roman binary either primes zipwith matrix wordcount powers caesar runlength-str showadt showio partial statistics newton wordfreq mapgraph uniquewords setops shapes person config counter accumulate) +PROGRAMS=(fib sieve quicksort nqueens calculator collatz palindrome maybe fizzbuzz anagram roman binary either primes zipwith matrix wordcount powers caesar runlength-str showadt showio partial statistics newton wordfreq mapgraph uniquewords setops shapes person config counter accumulate safediv trycatch) PASS_COUNTS=() FAIL_COUNTS=() diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 16750e1c..0aa4f8e9 100644 --- a/lib/haskell/eval.sx +++ b/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 diff --git a/lib/haskell/runtime.sx b/lib/haskell/runtime.sx index 18931dff..84e3b51e 100644 --- a/lib/haskell/runtime.sx +++ b/lib/haskell/runtime.sx @@ -102,6 +102,7 @@ (hk-register-con! "LT" 0 "Ordering") (hk-register-con! "EQ" 0 "Ordering") (hk-register-con! "GT" 0 "Ordering") +(hk-register-con! "SomeException" 1 "SomeException") (define hk-str? diff --git a/lib/haskell/scoreboard.json b/lib/haskell/scoreboard.json index 1c9a4dea..aaf032f0 100644 --- a/lib/haskell/scoreboard.json +++ b/lib/haskell/scoreboard.json @@ -1,6 +1,6 @@ { - "date": "2026-05-07", - "total_pass": 269, + "date": "2026-05-08", + "total_pass": 285, "total_fail": 0, "programs": { "fib": {"pass": 2, "fail": 0}, @@ -36,6 +36,8 @@ "person": {"pass": 7, "fail": 0}, "config": {"pass": 10, "fail": 0}, "counter": {"pass": 7, "fail": 0}, - "accumulate": {"pass": 8, "fail": 0} + "accumulate": {"pass": 8, "fail": 0}, + "safediv": {"pass": 8, "fail": 0}, + "trycatch": {"pass": 8, "fail": 0} } } diff --git a/lib/haskell/scoreboard.md b/lib/haskell/scoreboard.md index 3ce93d52..d632002c 100644 --- a/lib/haskell/scoreboard.md +++ b/lib/haskell/scoreboard.md @@ -1,6 +1,6 @@ # Haskell-on-SX Scoreboard -Updated 2026-05-07 · Phase 6 (prelude extras + 18 programs) +Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs) | Program | Tests | Status | |---------|-------|--------| @@ -38,4 +38,6 @@ Updated 2026-05-07 · Phase 6 (prelude extras + 18 programs) | config.hs | 10/10 | ✓ | | counter.hs | 7/7 | ✓ | | accumulate.hs | 8/8 | ✓ | -| **Total** | **269/269** | **34/34 programs** | +| safediv.hs | 8/8 | ✓ | +| trycatch.hs | 8/8 | ✓ | +| **Total** | **285/285** | **36/36 programs** | diff --git a/lib/haskell/tests/exceptions.sx b/lib/haskell/tests/exceptions.sx new file mode 100644 index 00000000..43140da1 --- /dev/null +++ b/lib/haskell/tests/exceptions.sx @@ -0,0 +1,105 @@ +;; Phase 16 — Exception handling unit tests. + +(hk-test + "catch — success path returns the action result" + (hk-deep-force + (hk-run + "main = catch (return 42) (\\(SomeException m) -> return 0)")) + (list "IO" 42)) + +(hk-test + "catch — error caught, handler receives message" + (hk-deep-force + (hk-run + "main = catch (error \"boom\") (\\(SomeException m) -> return m)")) + (list "IO" "boom")) + +(hk-test + "try — success returns Right v" + (hk-deep-force + (hk-run "main = try (return 42)")) + (list "IO" (list "Right" 42))) + +(hk-test + "try — error returns Left (SomeException msg)" + (hk-deep-force + (hk-run "main = try (error \"oops\")")) + (list "IO" (list "Left" (list "SomeException" "oops")))) + +(hk-test + "handle — flip catch — caught error message" + (hk-deep-force + (hk-run + "main = handle (\\(SomeException m) -> return m) (error \"hot\")")) + (list "IO" "hot")) + +(hk-test + "throwIO + catch — handler sees the SomeException" + (hk-deep-force + (hk-run + "main = catch (throwIO (SomeException \"bang\")) (\\(SomeException m) -> return m)")) + (list "IO" "bang")) + +(hk-test + "throwIO + try — Left side" + (hk-deep-force + (hk-run + "main = try (throwIO (SomeException \"x\"))")) + (list "IO" (list "Left" (list "SomeException" "x")))) + +(hk-test + "evaluate — pure value returns IO v" + (hk-deep-force + (hk-run "main = evaluate (1 + 2 + 3)")) + (list "IO" 6)) + +(hk-test + "evaluate — error surfaces as catchable exception" + (hk-deep-force + (hk-run + "main = catch (evaluate (error \"deep\")) (\\(SomeException m) -> return m)")) + (list "IO" "deep")) + +(hk-test + "nested catch — inner handler runs first" + (hk-deep-force + (hk-run + "main = catch (catch (error \"inner\") (\\(SomeException m) -> error (m ++ \"-rethrown\"))) (\\(SomeException m) -> return m)")) + (list "IO" "inner-rethrown")) + +(hk-test + "catch chain — handler can succeed inside IO" + (hk-deep-force + (hk-run + "main = do { x <- catch (error \"e1\") (\\(SomeException m) -> return 100); return (x + 1) }")) + (list "IO" 101)) + +(hk-test + "try then bind on Right" + (hk-deep-force + (hk-run + "branch (Right v) = return (v * 2) +branch (Left _) = return 0 +main = do { r <- try (return 21); branch r }")) + (list "IO" 42)) + +(hk-test + "try then bind on Left" + (hk-deep-force + (hk-run + "branch (Right _) = return \"ok\" +branch (Left (SomeException m)) = return m +main = do { r <- try (error \"failed\"); branch r }")) + (list "IO" "failed")) + +(hk-test + "catch — handler can use closed-over IORef" + (hk-deep-force + (hk-run + "import qualified Data.IORef as IORef +main = do + r <- IORef.newIORef 0 + catch (error \"x\") (\\(SomeException m) -> IORef.writeIORef r 7) + v <- IORef.readIORef r + return v")) + (list "IO" 7)) diff --git a/lib/haskell/tests/program-safediv.sx b/lib/haskell/tests/program-safediv.sx new file mode 100644 index 00000000..9dcc8cc0 --- /dev/null +++ b/lib/haskell/tests/program-safediv.sx @@ -0,0 +1,80 @@ +;; safediv.hs — safe division using catch (Phase 16 conformance). + +(define + hk-safediv-source + "safeDiv :: Int -> Int -> IO Int +safeDiv _ 0 = throwIO (SomeException \"division by zero\") +safeDiv x y = return (x `div` y) + +guarded :: Int -> Int -> IO Int +guarded x y = catch (safeDiv x y) (\\(SomeException _) -> return 0) + +reason :: Int -> Int -> IO String +reason x y = catch (safeDiv x y `seq` return \"ok\") + (\\(SomeException m) -> return m) + +bothBranches :: Int -> Int -> IO Int +bothBranches x y = do + v <- catch (safeDiv x y) (\\(SomeException _) -> return (-1)) + return (v + 100) + +") + +(hk-test + "safediv.hs — divide by non-zero" + (hk-deep-force + (hk-run + (str hk-safediv-source "main = guarded 10 2"))) + (list "IO" 5)) + +(hk-test + "safediv.hs — divide by zero returns 0" + (hk-deep-force + (hk-run + (str hk-safediv-source "main = guarded 10 0"))) + (list "IO" 0)) + +(hk-test + "safediv.hs — divide by zero — reason captured" + (hk-deep-force + (hk-run + (str hk-safediv-source "main = catch (safeDiv 1 0) (\\(SomeException m) -> return 0) >> reason 1 0"))) + (list "IO" "division by zero")) + +(hk-test + "safediv.hs — bothBranches success path" + (hk-deep-force + (hk-run + (str hk-safediv-source "main = bothBranches 8 2"))) + (list "IO" 104)) + +(hk-test + "safediv.hs — bothBranches failure path" + (hk-deep-force + (hk-run + (str hk-safediv-source "main = bothBranches 8 0"))) + (list "IO" 99)) + +(hk-test + "safediv.hs — chained safeDiv with catch" + (hk-deep-force + (hk-run + (str hk-safediv-source + "main = do { a <- guarded 20 4; b <- guarded 7 0; return (a + b) }"))) + (list "IO" 5)) + +(hk-test + "safediv.hs — try then bind through Either" + (hk-deep-force + (hk-run + (str hk-safediv-source + "main = do { r <- try (safeDiv 1 0); case r of { Right v -> return v; Left (SomeException m) -> return 999 } }"))) + (list "IO" 999)) + +(hk-test + "safediv.hs — handle (flip catch)" + (hk-deep-force + (hk-run + (str hk-safediv-source + "main = handle (\\(SomeException _) -> return 0) (safeDiv 5 0)"))) + (list "IO" 0)) diff --git a/lib/haskell/tests/program-trycatch.sx b/lib/haskell/tests/program-trycatch.sx new file mode 100644 index 00000000..cc1b7721 --- /dev/null +++ b/lib/haskell/tests/program-trycatch.sx @@ -0,0 +1,95 @@ +;; trycatch.hs — try pattern: branch on Left/Right (Phase 16 conformance). + +(define + hk-trycatch-source + "parseInt :: String -> IO Int +parseInt \"zero\" = return 0 +parseInt \"one\" = return 1 +parseInt \"two\" = return 2 +parseInt s = throwIO (SomeException (\"unknown: \" ++ s)) + +describe :: Either SomeException Int -> String +describe (Right v) = \"got \" ++ show v +describe (Left (SomeException m)) = \"err: \" ++ m + +trial :: String -> IO String +trial s = do + r <- try (parseInt s) + return (describe r) + +run3 :: String -> String -> String -> IO [String] +run3 a b c = do + ra <- trial a + rb <- trial b + rc <- trial c + return [ra, rb, rc] + +") + +(hk-test + "trycatch.hs — Right branch" + (hk-deep-force + (hk-run + (str hk-trycatch-source "main = trial \"one\""))) + (list "IO" "got 1")) + +(hk-test + "trycatch.hs — Left branch with message" + (hk-deep-force + (hk-run + (str hk-trycatch-source "main = trial \"banana\""))) + (list "IO" "err: unknown: banana")) + +(hk-test + "trycatch.hs — chain over three inputs, all good" + (hk-deep-force + (hk-run + (str hk-trycatch-source "main = run3 \"zero\" \"one\" \"two\""))) + (list "IO" + (list ":" "got 0" + (list ":" "got 1" + (list ":" "got 2" + (list "[]")))))) + +(hk-test + "trycatch.hs — chain over three inputs, mixed" + (hk-deep-force + (hk-run + (str hk-trycatch-source "main = run3 \"zero\" \"qux\" \"two\""))) + (list "IO" + (list ":" "got 0" + (list ":" "err: unknown: qux" + (list ":" "got 2" + (list "[]")))))) + +(hk-test + "trycatch.hs — Left from throwIO carries message" + (hk-deep-force + (hk-run + (str hk-trycatch-source + "main = do { r <- try (throwIO (SomeException \"explicit\")); return (describe r) }"))) + (list "IO" "err: explicit")) + +(hk-test + "trycatch.hs — Right preserves the int" + (hk-deep-force + (hk-run + (str hk-trycatch-source + "main = do { r <- try (return 42); return (describe r) }"))) + (list "IO" "got 42")) + +(hk-test + "trycatch.hs — pattern-bind on Right inside do" + (hk-deep-force + (hk-run + (str hk-trycatch-source + "main = do { Right v <- try (parseInt \"two\"); return (v + 100) }"))) + (list "IO" 102)) + +(hk-test + "trycatch.hs — handle alias on parseInt failure" + (hk-deep-force + (hk-run + (str hk-trycatch-source + "main = handle (\\(SomeException m) -> return (\"caught: \" ++ m)) (parseInt \"nope\" >>= (\\v -> return (show v)))"))) + (list "IO" "caught: unknown: nope")) diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index 5e7d78b6..7a7dbdc9 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -292,21 +292,21 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. ### Phase 16 — Exception handling -- [ ] `SomeException` type: `data SomeException = SomeException String`. +- [x] `SomeException` type: `data SomeException = SomeException String`. `IOException = SomeException`. -- [ ] `throwIO :: Exception e => e -> IO a` — raises `("hk-exception" e)`. -- [ ] `evaluate :: a -> IO a` — forces arg strictly; any embedded `hk-error` +- [x] `throwIO :: Exception e => e -> IO a` — raises `("hk-exception" e)`. +- [x] `evaluate :: a -> IO a` — forces arg strictly; any embedded `hk-error` surfaces as a catchable `SomeException`. -- [ ] `catch :: Exception e => IO a -> (e -> IO a) -> IO a` — wraps action in +- [x] `catch :: Exception e => IO a -> (e -> IO a) -> IO a` — wraps action in SX `guard`; on `hk-error` or `hk-exception`, calls the handler with a `SomeException` value. -- [ ] `try :: Exception e => IO a -> IO (Either e a)` — returns `Right v` on +- [x] `try :: Exception e => IO a -> IO (Either e a)` — returns `Right v` on success, `Left e` on any exception. -- [ ] `handle = flip catch`. -- [ ] Tests in `lib/haskell/tests/exceptions.sx` (≥ 10 tests: catch success, +- [x] `handle = flip catch`. +- [x] Tests in `lib/haskell/tests/exceptions.sx` (≥ 10 tests: catch success, catch error, try Right, try Left, nested catch, evaluate surfaces error, throwIO propagates, handle alias). -- [ ] Conformance programs: +- [x] Conformance programs: - `safediv.hs` — safe division using `catch`; divide-by-zero raises, handler returns 0. - `trycatch.hs` — `try` pattern: run an action, branch on Left/Right. @@ -315,6 +315,19 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. _Newest first._ +**2026-05-08** — Phase 16 Exception handling complete (6 ops + module wiring + +14 unit tests + 2 conformance programs). `hk-bind-exceptions!` in `eval.sx` +registers `throwIO`, `throw`, `evaluate`, `catch`, `try`, `handle`, and +`displayException`. `SomeException` constructor pre-registered in +`runtime.sx`. `throwIO` and the `error` primitive both raise via SX `raise` +with a uniform `"hk-error: msg"` string; catch/try/handle parse this string +back into a `SomeException` via `hk-exception-of` (which strips nested +`Unhandled exception: "..."` host wraps and the `hk-error: ` prefix). catch +and handle evaluate the handler outside the guard scope, so a re-throw from +the handler propagates past this catch (matching Haskell semantics, not an +infinite loop). Phase 16 phase complete: scoreboard now 285/285 tests, +36/36 programs. + **2026-05-07** — Fix string ↔ `[Char]` equality. `reverse`/`length`/`head`/etc. on a string transparently coerce to a cons-list of char codes via `hk-str-head` + `hk-str-tail`, but `(==)` then compared the original raw string against the