coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

haskell: Phase 7 string=[Char] — O(1) string-view head/tail + chr/ord/toUpper/toLower/++ (+35 tests, 810/810)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 49s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 19:44:19 +00:00
parent 859361d86a
commit 4a35998469
5 changed files with 315 additions and 69 deletions
Download Patch File Download Diff File Expand all files Collapse all files

76
lib/haskell/match.sx
View File

@@ -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` —