diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 0d8035b7..fef5e254 100644 --- a/lib/haskell/eval.sx +++ b/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" diff --git a/lib/haskell/tests/eval.sx b/lib/haskell/tests/eval.sx index 560bd90f..53682429 100644 --- a/lib/haskell/tests/eval.sx +++ b/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} diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index c1f19f6f..14f0186a 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -122,7 +122,11 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. ### Phase 9 — `error` / `undefined` -- [ ] `error :: String -> a` — raises `(raise (list "hk-error" msg))` in SX. +- [x] `error :: String -> a` — raises `(raise "hk-error: ")` in SX. + _Plan amended:_ SX's `apply` rewrites unhandled list raises to a string + `"Unhandled exception: "` before any user handler sees them, so + the tag has to live in a string prefix rather than as the head of a list. + Catchers use `(index-of e "hk-error: ")` to detect. - [ ] `undefined :: a` = `error "Prelude.undefined"`. - [ ] Partial functions emit proper error messages: `head []` → `"Prelude.head: empty list"`, `tail []` → `"Prelude.tail: empty list"`, @@ -289,6 +293,18 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. _Newest first._ +**2026-05-07** — Phase 9 `error :: String -> a` raises with `hk-error:` prefix: +- Pre-existing `error` builtin was raising `"*** Exception: "` (GHC + console convention). Renamed prefix to `"hk-error: "` so the wrap-around + string SX's `apply` produces (`"Unhandled exception: \"hk-error: ...\""`) + contains a stable, searchable tag. +- Investigation confirmed that the plan's intended `(raise (list "hk-error" msg))` + format is mangled by SX `apply` to a string. Plan note added; tests use + `index-of` substring matching against the wrapped string. +- 2 new tests in `tests/eval.sx` (string and computed-message form). Suite + is 57/57. Other test suites unchanged (match 31/31, stdlib 48/48, derive + 15/15, do-io 16/16, class 14/14). + **2026-05-07** — Phase 8 conformance: `showadt.hs` + `showio.hs` (both 5/5): - `program-showadt.sx`: `deriving (Show)` on the classic `Expr = Lit | Add | Mul` recursive ADT; tests `print` on three nested expressions and inline `show`