diff options
Diffstat (limited to 'module/hnh/util/object.scm')
| -rw-r--r-- | module/hnh/util/object.scm | 41 |
1 files changed, 40 insertions, 1 deletions
diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm index 813a59ce..68703e1e 100644 --- a/module/hnh/util/object.scm +++ b/module/hnh/util/object.scm @@ -112,11 +112,35 @@ (datum->syntax stx)))) #'(name name-get name-set))))) +;;; Name of the created accessor +(define (accessor-name field) + (syntax-case field () + ((name kvs ...) + (cond ((kv-ref #'(kvs ...) accessor:) + => identity) + (else #'name))) + (name #'name))) + +;;; Name of the created lens +(define (lens-name field) + (syntax-case field () + ((name kvs ...) + (cond ((kv-ref #'(kvs ...) lens:) + => identity) + (else (->> (syntax->datum #'name) + (format #f "~a*") + string->symbol + (datum->syntax field))))) + (name (->> (syntax->datum #'name) + (format #f "~a*") + string->symbol + (datum->syntax field))))) + ;; Accessors are procedures for getting and setting fields in records (define-syntax (build-accessor stx) (syntax-case stx () ((_ type-name (name kvs ...)) - #'(define name + #`(define #,(accessor-name #'(name kvs ...)) (case-lambda ((datum) ((field-get type-name name) datum)) ((datum new-value) @@ -126,10 +150,23 @@ ;; while keeping name bound to the accessor in the outer scope. (let ((name new-value)) (validator name (name kvs ...))) + ((field-set type-name name) datum new-value))))) + ((_ type-name name) #'(build-accessor type-name (name))))) +(define (build-lenses stx fields) + (map (lambda (field) + (with-syntax ((lens* (lens-name field)) + (accessor (accessor-name field))) + #'(define (lens* object) + (lambda (op) + (accessor object + (op (accessor object))))))) + fields)) + + (define (syntax-name field) (syntax-case field () ((name kvs ...) @@ -187,6 +224,8 @@ ;; Field accessors (build-accessor name field) ... + #,@(build-lenses stx #'(field ...)) + ;; if printer in attribute #,@(cond ((kv-ref #'(attribute ...) printer:) => (lambda (printer) |