-(define-macro (define-component name . args)
- `(begin
- (use-modules (srfi srfi-9) (srfi srfi-9 gnu))
- (define-record-type ,name
- (,(symbol-concatenate "make-" name) ,@args)
- ,(symbol-concatenate name "?")
- ,@(map (lambda (a) (list a (symbol-concatenate name "-" a) (symbol-concatenate "set-" name "-" a "!"))) args))
- (set-record-type-printer! ,name
- (lambda (record port)
- (format port "#<[~a]" ',name)
- ,@(map (lambda (a) `(format port " ~a: ~a" ',a (,(symbol-concatenate name "-" a) record))) args)
- (format port ">")))
- ',name))
+(define-syntax define-component
+ (lambda (x)
+ (define (concat . args)
+ (datum->syntax x
+ (apply symbol-concatenate
+ (map (lambda (a)
+ (if (string? a)
+ a
+ (syntax->datum a)))
+ args))))
+ (define (filtered-args args)
+ (let ((datum (map (lambda (a) (syntax->datum a)) args)))
+ (map (lambda (a) (datum->syntax x a))
+ (map (lambda (a) (if (list? a) (car a) a))
+ (filter (lambda (a) (not (keyword? a))) datum)))))
+ (syntax-case x ()
+ ((_ name field ...)
+ (with-syntax ((make-name (concat "make-" #'name))
+ (make-name-record (concat "make-" #'name "-record"))
+ (name? (concat #'name "?"))
+ ((field-name ...) (filtered-args #'(field ...)))
+ ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) (filtered-args #'(field ...))))
+ ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) (filtered-args #'(field ...)))))
+ #'(begin
+ (define* (make-name field ...)
+ (make-name-record field-name ...))
+ (define-record-type name
+ (make-name-record field-name ...)
+ name?
+ (field-name field-getter field-setter)
+ ...)
+ (set-record-type-printer! name
+ (lambda (record port)
+ (format port "#<[~a]" 'name)
+ (format port " ~a: ~a" 'field-name (field-getter record))
+ ...
+ (format port ">")))
+ 'name))))))