From 2222f55c422fc72f392b1f40ce1dee97b30c17d9 Mon Sep 17 00:00:00 2001
From: mehbark <terezi@pyrope.net>
Date: Sun, 23 Feb 2025 18:35:50 -0500
Subject: [PATCH] feat: `define-record-{equality,matcher}!`
these are great
---
record.sls | 42 ++++++++++++++++++++++++++++++++++++++++++
std.sls | 3 ++-
2 files changed, 44 insertions(+), 1 deletion(-)
create mode 100644 record.sls
diff --git a/record.sls b/record.sls
new file mode 100644
index 0000000..015a863
--- /dev/null
+++ b/record.sls
@@ -0,0 +1,42 @@
+(library (meh record)
+ (export define-record-equality! define-record-matcher!)
+ (import (chezscheme)
+ (meh match))
+
+(define-syntax define-record-equality!
+ (syntax-rules ()
+ [(_ record-type-name)
+ (let ()
+ (define rtd (record-type-descriptor record-type-name))
+ (define field-count (vector-length (record-type-field-names rtd)))
+ (define accessors
+ (do ([i 0 (add1 i)]
+ [as '() (cons (record-accessor rtd i) as)])
+ [(= i field-count) (reverse! as)]))
+ (record-type-equal-procedure rtd
+ (lambda (r1 r2 =)
+ (for-all
+ (lambda (accessor) (= (accessor r1) (accessor r2)))
+ accessors))))]
+ [(_ name name* ...)
+ (begin (define-record-equality! name)
+ (define-record-equality! name*) ...)]))
+
+(define-syntax define-record-matcher!
+ (syntax-rules ()
+ [(_ record-type-name)
+ (define-pattern record-type-name
+ (lambda (e)
+ (syntax-case e ()
+ [(_ pat* (... ...))
+ (with-syntax ([rtd #'(record-type-descriptor record-type-name)]
+ [(idx* (... ...))
+ (datum->syntax
+ #'* (iota (length (syntax->list #'(pat* (... ...))))))])
+ #'(and (guard x (record? x rtd))
+ (access (record-accessor rtd idx*) pat*)
+ (... ...)))])))]
+ [(_ name name* ...)
+ (begin (define-record-matcher! name)
+ (define-record-matcher! name*) ...)]))
+)
diff --git a/std.sls b/std.sls
index bca7e57..b2580bc 100644
--- a/std.sls
+++ b/std.sls
@@ -16,7 +16,8 @@
(import (chezscheme))
- (export (import (meh match)))
+ (export (import (meh match))
+ (import (meh record)))
;;; SYNTAX