On Thu, May 28, 2009 at 2:05 AM, Eduardo Cavazos <[email protected]> wrote:
> Another thing I often do with records is apply a procedure to the
> field values. For example, here are two procedures in a library of mine:
> ...
> (define-syntax define-record-type++
> ...
Thanks.
Here is a macro to generate the defaults. Leppie helped me past the
roadblock of iterating over a list of field names. I am interested for
you feedback as I am not the most skilled with macros. Clearly this
works, but I learned a fair bit writing. I just don't feel like I've
really internalized macros. Working on this helped.
(define-syntax define-record-type++/default
(lambda (stx)
(syntax-case stx ()
((this name (the-fields ...))
(let* ((name-prepend (lambda (str stx)
(datum->syntax
#'this
(string->symbol
(string-append str
(symbol->string
(syntax->datum stx)))))))
(name-append (lambda (str stx)
(datum->syntax
#'this
(string->symbol
(string-append (symbol->string
(syntax->datum stx))
str)))))
(name-wrap (lambda (str rec field)
(datum->syntax
#'this
(string->symbol
(string-append (symbol->string (syntax->datum rec))
str
(symbol->string
(syntax->datum field)))))))
(gen-fields
(lambda (rec-stx names-stx)
(with-syntax ([(all-names ...) names-stx])
#`(fields
#,@(let loop ([names #'(all-names ...)])
(with-syntax ([(first rest ...) names])
(with-syntax ([mutable (datum->syntax
#'this 'mutable)]
[accessor (name-wrap "-"
rec-stx #'first)]
[mutator (name-wrap
"-set!-" rec-stx #'first)]
[changer (name-wrap
"-change-" rec-stx #'first)])
(if (null? #'(rest ...))
#'((mutable first accessor mutator changer))
#`((mutable first accessor mutator changer)
#,@(loop (cdr names))))))))))))
(with-syntax ((constructor (name-prepend "make-" #'name))
(predicate (name-append "?" #'name))
(cloner (name-prepend "clone-" #'name))
(assigner (name-prepend "assign-" #'name))
(applier (name-prepend "apply-" #'name))
(fields-body (gen-fields #'name #'(the-fields ...))))
#'(define-record-type++
(name constructor predicate cloner assigner applier)
fields-body)))))))
