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

haskell: thunks + force, app args become lazy (+6 tests, 333/333)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source
This commit is contained in:
giles
2026-04-24 23:22:21 +00:00
parent fba92c2b69
commit 0e53e88b02
4 changed files with 222 additions and 94 deletions
Download Patch File Download Diff File Expand all files Collapse all files

155
lib/haskell/match.sx
View File

@@ -60,6 +60,12 @@
(define hk-val-con-args (fn (v) (rest v)))
;; ── The matcher ────────────────────────────────────────────
;;
;; Pattern match forces the scrutinee to WHNF before inspecting it
;; — except for `p-wild`, `p-var`, and `p-lazy`, which never need
;; to look at the value. Args of constructor / tuple / list values
;; remain thunked (they're forced only when their own pattern needs
;; to inspect them, recursively).
(define
hk-match
(fn
@@ -73,65 +79,69 @@
(cond
((= tag "p-wild") env)
((= tag "p-var") (assoc env (nth pat 1) val))
((= tag "p-int")
(if
(and (number? val) (= val (nth pat 1)))
env
nil))
((= tag "p-float")
(if
(and (number? val) (= val (nth pat 1)))
env
nil))
((= tag "p-string")
(if
(and (string? val) (= val (nth pat 1)))
env
nil))
((= tag "p-char")
(if
(and (string? val) (= val (nth pat 1)))
env
nil))
((= tag "p-lazy") (hk-match (nth pat 1) val env))
((= tag "p-as")
(let
((res (hk-match (nth pat 2) val env)))
(cond
((nil? res) nil)
(:else (assoc res (nth pat 1) val)))))
((= tag "p-lazy")
;; Eager match for now; phase 3 wires laziness back in.
(hk-match (nth pat 1) val env))
((= tag "p-con")
(let
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
(:else
(let ((fv (hk-force val)))
(cond
((not (hk-is-con-val? val)) nil)
((not (= (hk-val-con-name val) pat-name)) nil)
(:else
((= tag "p-int")
(if
(and (number? fv) (= fv (nth pat 1)))
env
nil))
((= tag "p-float")
(if
(and (number? fv) (= fv (nth pat 1)))
env
nil))
((= tag "p-string")
(if
(and (string? fv) (= fv (nth pat 1)))
env
nil))
((= tag "p-char")
(if
(and (string? fv) (= fv (nth pat 1)))
env
nil))
((= tag "p-con")
(let
((val-args (hk-val-con-args val)))
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
(cond
((not (= (len pat-args) (len val-args)))
((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))))))))
((= tag "p-tuple")
(let
((items (nth pat 1)))
(cond
((not (hk-is-con-val? fv)) nil)
((not (= (hk-val-con-name fv) "Tuple")) nil)
((not (= (len (hk-val-con-args fv)) (len items)))
nil)
(:else
(hk-match-all pat-args val-args env))))))))
((= tag "p-tuple")
(let
((items (nth pat 1)))
(cond
((not (hk-is-con-val? val)) nil)
((not (= (hk-val-con-name val) "Tuple")) nil)
((not (= (len (hk-val-con-args val)) (len items)))
nil)
(:else
(hk-match-all
items
(hk-val-con-args val)
env)))))
((= tag "p-list")
(hk-match-list-pat (nth pat 1) val env))
(:else nil)))))))
(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
hk-match-all
@@ -151,32 +161,33 @@
hk-match-list-pat
(fn
(items val env)
(cond
((empty? items)
(if
(and
(hk-is-con-val? val)
(= (hk-val-con-name val) "[]"))
env
nil))
(:else
(cond
((not (hk-is-con-val? val)) nil)
((not (= (hk-val-con-name val) ":")) nil)
(:else
(let
((args (hk-val-con-args val)))
(let ((fv (hk-force val)))
(cond
((empty? items)
(if
(and
(hk-is-con-val? fv)
(= (hk-val-con-name fv) "[]"))
env
nil))
(:else
(cond
((not (hk-is-con-val? fv)) nil)
((not (= (hk-val-con-name fv) ":")) nil)
(:else
(let
((h (first args)) (t (first (rest args))))
((args (hk-val-con-args fv)))
(let
((res (hk-match (first items) h env)))
(cond
((nil? res) nil)
(:else
(hk-match-list-pat
(rest items)
t
res))))))))))))
((h (first args)) (t (first (rest args))))
(let
((res (hk-match (first items) h env)))
(cond
((nil? res) nil)
(: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` —