45 lines
1.7 KiB
Scheme
45 lines
1.7 KiB
Scheme
(library (meh record)
|
|
(export define-record-equality! define-record-pattern!)
|
|
(import (chezscheme)
|
|
(meh match))
|
|
|
|
(define-syntax define-record-equality!
|
|
(syntax-rules ()
|
|
[(_ record-type-name)
|
|
;; pointless definition ensures that you can do (begin (define) (define-record-equality!) (define))
|
|
(define _
|
|
(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-pattern!
|
|
(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-pattern! name)
|
|
(define-record-pattern! name*) ...)]))
|
|
)
|