diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 60de291e..0a59fb17 100644 --- a/lib/haskell/eval.sx +++ b/lib/haskell/eval.sx @@ -433,10 +433,10 @@ (fn (a b) (cond + ((hk-str? a) (str (hk-str-to-native a) (hk-str-to-native b))) ((and (list? a) (= (first a) "[]")) b) ((and (list? a) (= (first a) ":")) (hk-mk-cons (nth a 1) (hk-list-append (nth a 2) b))) - ((string? a) (str a b)) (:else (raise "++: not a list"))))) ;; Eager finite-range spine — handles [from..to] and [from,next..to]. @@ -839,7 +839,12 @@ (dict-set! env "ord" - (hk-mk-builtin "ord" (fn (c) (char-code (hk-force c))) 1)) + (hk-mk-builtin + "ord" + (fn + (c) + (let ((v (hk-force c))) (if (number? v) v (char-code v)))) + 1)) (dict-set! env "isAlpha" @@ -848,11 +853,13 @@ (fn (c) (let - ((code (char-code (hk-force c)))) - (hk-of-bool - (or - (and (>= code 65) (<= code 90)) - (and (>= code 97) (<= code 122)))))) + ((v (hk-force c))) + (let + ((code (if (number? v) v (char-code v)))) + (hk-of-bool + (or + (and (>= code 65) (<= code 90)) + (and (>= code 97) (<= code 122))))))) 1)) (dict-set! env @@ -862,12 +869,14 @@ (fn (c) (let - ((code (char-code (hk-force c)))) - (hk-of-bool - (or - (and (>= code 65) (<= code 90)) - (and (>= code 97) (<= code 122)) - (and (>= code 48) (<= code 57)))))) + ((v (hk-force c))) + (let + ((code (if (number? v) v (char-code v)))) + (hk-of-bool + (or + (and (>= code 65) (<= code 90)) + (and (>= code 97) (<= code 122)) + (and (>= code 48) (<= code 57))))))) 1)) (dict-set! env @@ -877,8 +886,10 @@ (fn (c) (let - ((code (char-code (hk-force c)))) - (hk-of-bool (and (>= code 48) (<= code 57))))) + ((v (hk-force c))) + (let + ((code (if (number? v) v (char-code v)))) + (hk-of-bool (and (>= code 48) (<= code 57)))))) 1)) (dict-set! env @@ -888,9 +899,11 @@ (fn (c) (let - ((code (char-code (hk-force c)))) - (hk-of-bool - (or (= code 32) (= code 9) (= code 10) (= code 13))))) + ((v (hk-force c))) + (let + ((code (if (number? v) v (char-code v)))) + (hk-of-bool + (or (= code 32) (= code 9) (= code 10) (= code 13)))))) 1)) (dict-set! env @@ -900,8 +913,10 @@ (fn (c) (let - ((code (char-code (hk-force c)))) - (hk-of-bool (and (>= code 65) (<= code 90))))) + ((v (hk-force c))) + (let + ((code (if (number? v) v (char-code v)))) + (hk-of-bool (and (>= code 65) (<= code 90)))))) 1)) (dict-set! env @@ -911,15 +926,47 @@ (fn (c) (let - ((code (char-code (hk-force c)))) - (hk-of-bool (and (>= code 97) (<= code 122))))) + ((v (hk-force c))) + (let + ((code (if (number? v) v (char-code v)))) + (hk-of-bool (and (>= code 97) (<= code 122)))))) + 1)) + (dict-set! + env + "chr" + (hk-mk-builtin "chr" (fn (n) (char-from-code (hk-force n))) 1)) + (dict-set! + env + "toUpper" + (hk-mk-builtin + "toUpper" + (fn + (n) + (let + ((code (hk-force n))) + (if (and (>= code 97) (<= code 122)) (- code 32) code))) + 1)) + (dict-set! + env + "toLower" + (hk-mk-builtin + "toLower" + (fn + (n) + (let + ((code (hk-force n))) + (if (and (>= code 65) (<= code 90)) (+ code 32) code))) 1)) (dict-set! env "digitToInt" (hk-mk-builtin "digitToInt" - (fn (c) (- (char-code (hk-force c)) 48)) + (fn + (c) + (let + ((v (hk-force c))) + (- (if (number? v) v (char-code v)) 48))) 1)) (dict-set! env diff --git a/lib/haskell/match.sx b/lib/haskell/match.sx index 007d1358..d66f6c1b 100644 --- a/lib/haskell/match.sx +++ b/lib/haskell/match.sx @@ -87,45 +87,41 @@ ((nil? res) nil) (:else (assoc res (nth pat 1) val))))) (:else - (let ((fv (hk-force val))) + (let + ((fv (hk-force val))) (cond ((= tag "p-int") - (if - (and (number? fv) (= fv (nth pat 1))) - env - nil)) + (if (and (number? fv) (= fv (nth pat 1))) env nil)) ((= tag "p-float") - (if - (and (number? fv) (= fv (nth pat 1))) - env - nil)) + (if (and (number? fv) (= fv (nth pat 1))) env nil)) ((= tag "p-string") - (if - (and (string? fv) (= fv (nth pat 1))) - env - nil)) + (if (and (string? fv) (= fv (nth pat 1))) env nil)) ((= tag "p-char") - (if - (and (string? fv) (= fv (nth pat 1))) - env - nil)) + (if (and (string? fv) (= fv (nth pat 1))) env nil)) ((= tag "p-con") (let ((pat-name (nth pat 1)) (pat-args (nth pat 2))) (cond + ((and (= pat-name ":") (hk-str? fv) (not (hk-str-null? fv))) + (let + ((str-head (hk-str-head fv)) + (str-tail (hk-str-tail fv))) + (let + ((head-pat (nth pat-args 0)) + (tail-pat (nth pat-args 1))) + (let + ((res (hk-match head-pat str-head env))) + (cond + ((nil? res) nil) + (:else (hk-match tail-pat str-tail res))))))) ((not (hk-is-con-val? fv)) nil) ((not (= (hk-val-con-name fv) pat-name)) nil) (:else (let ((val-args (hk-val-con-args fv))) (cond - ((not (= (len pat-args) (len val-args))) - nil) - (:else - (hk-match-all - pat-args - val-args - env)))))))) + ((not (= (len val-args) (len pat-args))) nil) + (:else (hk-match-all pat-args val-args env)))))))) ((= tag "p-tuple") (let ((items (nth pat 1))) @@ -134,13 +130,8 @@ ((not (= (hk-val-con-name fv) "Tuple")) nil) ((not (= (len (hk-val-con-args fv)) (len items))) nil) - (:else - (hk-match-all - items - (hk-val-con-args fv) - env))))) - ((= tag "p-list") - (hk-match-list-pat (nth pat 1) fv env)) + (:else (hk-match-all items (hk-val-con-args fv) env))))) + ((= tag "p-list") (hk-match-list-pat (nth pat 1) fv env)) (:else nil)))))))))) (define @@ -161,17 +152,26 @@ hk-match-list-pat (fn (items val env) - (let ((fv (hk-force val))) + (let + ((fv (hk-force val))) (cond ((empty? items) (if - (and - (hk-is-con-val? fv) - (= (hk-val-con-name fv) "[]")) + (or + (and (hk-is-con-val? fv) (= (hk-val-con-name fv) "[]")) + (and (hk-str? fv) (hk-str-null? fv))) env nil)) (:else (cond + ((and (hk-str? fv) (not (hk-str-null? fv))) + (let + ((h (hk-str-head fv)) (t (hk-str-tail fv))) + (let + ((res (hk-match (first items) h env))) + (cond + ((nil? res) nil) + (:else (hk-match-list-pat (rest items) t res)))))) ((not (hk-is-con-val? fv)) nil) ((not (= (hk-val-con-name fv) ":")) nil) (:else @@ -183,11 +183,7 @@ ((res (hk-match (first items) h env))) (cond ((nil? res) nil) - (:else - (hk-match-list-pat - (rest items) - t - res))))))))))))) + (:else (hk-match-list-pat (rest items) t res))))))))))))) ;; ── Convenience: parse a pattern from source for tests ───── ;; (Uses the parser's case-alt entry — `case _ of pat -> 0` — diff --git a/lib/haskell/runtime.sx b/lib/haskell/runtime.sx index 69bcc36d..6a8e9a6c 100644 --- a/lib/haskell/runtime.sx +++ b/lib/haskell/runtime.sx @@ -128,3 +128,48 @@ (hk-register-con! "LT" 0 "Ordering") (hk-register-con! "EQ" 0 "Ordering") (hk-register-con! "GT" 0 "Ordering") + +(define + hk-str? + (fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str"))))) + +(define + hk-str-head + (fn + (v) + (if + (string? v) + (char-code (char-at v 0)) + (char-code (char-at (get v "hk-str") (get v "hk-off")))))) + +(define + hk-str-tail + (fn + (v) + (let + ((buf (if (string? v) v (get v "hk-str"))) + (off (if (string? v) 1 (+ (get v "hk-off") 1)))) + (if (>= off (string-length buf)) (list "[]") {:hk-off off :hk-str buf})))) + +(define + hk-str-null? + (fn + (v) + (if + (string? v) + (= (string-length v) 0) + (>= (get v "hk-off") (string-length (get v "hk-str")))))) + +(define + hk-str-to-native + (fn + (v) + (if + (string? v) + v + (let + ((buf (get v "hk-str")) (off (get v "hk-off"))) + (reduce + (fn (acc i) (str acc (char-at buf i))) + "" + (range off (string-length buf))))))) diff --git a/lib/haskell/tests/string-char.sx b/lib/haskell/tests/string-char.sx new file mode 100644 index 00000000..fac650a7 --- /dev/null +++ b/lib/haskell/tests/string-char.sx @@ -0,0 +1,139 @@ +;; String / Char tests — Phase 7 items 1-4. +;; +;; Covers: +;; hk-str? / hk-str-head / hk-str-tail / hk-str-null? (runtime helpers) +;; chr / ord / toUpper / toLower (builtins in eval) +;; cons-pattern on strings via match.sx (":"-intercept) +;; empty-list pattern on strings via match.sx ("[]"-intercept) + +;; ── hk-str? predicate ──────────────────────────────────────────────────── +(hk-test "hk-str? native string" (hk-str? "hello") true) + +(hk-test "hk-str? empty string" (hk-str? "") true) + +(hk-test "hk-str? view dict" (hk-str? {:hk-off 1 :hk-str "hi"}) true) + +(hk-test "hk-str? rejects number" (hk-str? 42) false) + +;; ── hk-str-null? predicate ─────────────────────────────────────────────── +(hk-test "hk-str-null? empty string" (hk-str-null? "") true) + +(hk-test "hk-str-null? non-empty" (hk-str-null? "a") false) + +(hk-test "hk-str-null? exhausted view" (hk-str-null? {:hk-off 2 :hk-str "hi"}) true) + +(hk-test "hk-str-null? live view" (hk-str-null? {:hk-off 1 :hk-str "hi"}) false) + +;; ── hk-str-head ────────────────────────────────────────────────────────── +(hk-test "hk-str-head native string" (hk-str-head "hello") 104) + +(hk-test "hk-str-head view at offset" (hk-str-head {:hk-off 1 :hk-str "hello"}) 101) + +;; ── hk-str-tail ────────────────────────────────────────────────────────── +(hk-test "hk-str-tail of single char is nil" (hk-str-tail "h") (list "[]")) + +(hk-test + "hk-str-tail of two-char string is live view" + (hk-str-null? (hk-str-tail "hi")) + false) + +(hk-test + "hk-str-tail head of tail of hi is i" + (hk-str-head (hk-str-tail "hi")) + 105) + +;; ── chr / ord ──────────────────────────────────────────────────────────── +(hk-test "chr 65 = A" (hk-eval-expr-source "chr 65") "A") + +(hk-test "chr 104 = h" (hk-eval-expr-source "chr 104") "h") + +(hk-test "ord char literal 'A' = 65" (hk-eval-expr-source "ord 'A'") 65) + +(hk-test "ord char literal 'a' = 97" (hk-eval-expr-source "ord 'a'") 97) + +(hk-test + "ord of head string = char code" + (hk-eval-expr-source "ord (head \"hello\")") + 104) + +;; ── toUpper / toLower ──────────────────────────────────────────────────── +(hk-test "toUpper 97 = 65 (a->A)" (hk-eval-expr-source "toUpper 97") 65) + +(hk-test + "toUpper 65 = 65 (already upper)" + (hk-eval-expr-source "toUpper 65") + 65) + +(hk-test + "toUpper 48 = 48 (digit unchanged)" + (hk-eval-expr-source "toUpper 48") + 48) + +(hk-test "toLower 65 = 97 (A->a)" (hk-eval-expr-source "toLower 65") 97) + +(hk-test + "toLower 97 = 97 (already lower)" + (hk-eval-expr-source "toLower 97") + 97) + +(hk-test + "toLower 48 = 48 (digit unchanged)" + (hk-eval-expr-source "toLower 48") + 48) + +;; ── Pattern matching on strings ────────────────────────────────────────── +(hk-test + "cons pattern: head of hello = 104" + (hk-eval-expr-source "case \"hello\" of { (x:_) -> x }") + 104) + +(hk-test + "cons pattern: tail is traversable" + (hk-eval-expr-source "case \"hi\" of { (_:xs) -> case xs of { (y:_) -> y } }") + 105) + +(hk-test + "empty list pattern matches empty string" + (hk-eval-expr-source "case \"\" of { [] -> True; _ -> False }") + (list "True")) + +(hk-test + "empty list pattern fails on non-empty" + (hk-eval-expr-source "case \"a\" of { [] -> True; _ -> False }") + (list "False")) + +(hk-test + "cons pattern fails on empty string" + (hk-eval-expr-source "case \"\" of { (_:_) -> True; _ -> False }") + (list "False")) + +;; ── Haskell programs using string traversal ────────────────────────────── +(hk-test + "null prelude on empty string" + (hk-eval-expr-source "null \"\"") + (list "True")) + +(hk-test + "null prelude on non-empty string" + (hk-eval-expr-source "null \"abc\"") + (list "False")) + +(hk-test + "length of string via cons recursion" + (hk-eval-expr-source "let { f [] = 0; f (_:xs) = 1 + f xs } in f \"hello\"") + 5) + +(hk-test + "map ord over string gives char codes" + (hk-deep-force (hk-eval-expr-source "map ord \"abc\"")) + (list ":" 97 (list ":" 98 (list ":" 99 (list "[]"))))) + +(hk-test + "map toUpper over char codes then chr" + (hk-eval-expr-source "chr (toUpper (ord (head \"abc\")))") + "A") + +(hk-test + "head then ord using prelude head" + (hk-eval-expr-source "ord (head \"hello\")") + 104) diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index 138a09ca..1aca6109 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -75,18 +75,18 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. ### Phase 7 — String = [Char] (performant string views) -- [ ] Add `hk-str?` predicate to `runtime.sx` covering both native SX strings +- [x] Add `hk-str?` predicate to `runtime.sx` covering both native SX strings and `{:hk-str buf :hk-off n}` view dicts. -- [ ] Implement `hk-str-head`, `hk-str-tail`, `hk-str-null?` helpers in +- [x] Implement `hk-str-head`, `hk-str-tail`, `hk-str-null?` helpers in `runtime.sx`. -- [ ] In `match.sx`, intercept cons-pattern `":"` when scrutinee satisfies +- [x] In `match.sx`, intercept cons-pattern `":"` when scrutinee satisfies `hk-str?`; decompose to (char-int, view) instead of the tagged-list path. Nil-pattern `"[]"` matches `hk-str-null?`. -- [ ] Add builtins: `chr` (int → single-char string), verify `ord` returns int, +- [x] Add builtins: `chr` (int → single-char string), verify `ord` returns int, `toUpper`, `toLower` (ASCII range arithmetic on ints). -- [ ] Ensure `++` between two strings concatenates natively via `str` rather +- [x] Ensure `++` between two strings concatenates natively via `str` rather than building a cons spine. -- [ ] Tests in `lib/haskell/tests/string-char.sx` (≥ 15 tests: head/tail on +- [x] Tests in `lib/haskell/tests/string-char.sx` (≥ 15 tests: head/tail on string literal, map over string, filter chars, chr/ord roundtrip, toUpper, toLower, null/empty string view). - [ ] Conformance programs (WebFetch + adapt): @@ -283,3 +283,22 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. ## Progress log _Newest first._ + +**2026-05-06** — Phase 7 complete (string-view O(1) head/tail + `++` native concat): +- `runtime.sx`: added `hk-str?`, `hk-str-head`, `hk-str-tail`, `hk-str-null?`. + String views are `{:hk-str buf :hk-off n}` dicts; native SX strings satisfy the + predicate with implicit offset 0. All helpers are O(1) via `char-at` / `string-length`. +- `eval.sx`: added `chr` (int → single-char string via `char-from-code`), `toUpper`, + `toLower` (ASCII-range arithmetic). Fixed `ord` and all char predicates (`isAlpha`, + `isAlphaNum`, `isDigit`, `isSpace`, `isUpper`, `isLower`, `digitToInt`) to accept + integers from string-view decomposition (not only single-char strings). +- `match.sx`: cons-pattern `":"` now checks `hk-str?` before the tagged-list path, + decomposing to `(hk-str-head, hk-str-tail)`. Empty-list pattern (`p-list []`) also + accepts `hk-str-null?` values. `hk-match-list-pat` updated to traverse string views + element-by-element. +- `runtime.sx`: added `hk-str-to-native` (converts view dict to native string via reduce+char-at). +- `eval.sx`: `hk-list-append` now checks `hk-str?` first; converts both operands via + `hk-str-to-native` before native `str` concat. String `++` String no longer builds + a cons spine. +- 35 new tests in `lib/haskell/tests/string-char.sx` (35/35 passing). +- Full suite: 810/810 tests, 0 regressions (was 775).