diff options
Diffstat (limited to 'module/hnh/util/object.scm')
| -rw-r--r-- | module/hnh/util/object.scm | 27 |
1 files changed, 20 insertions, 7 deletions
diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm index 4477b462..9c95010d 100644 --- a/module/hnh/util/object.scm +++ b/module/hnh/util/object.scm @@ -1,4 +1,5 @@ (define-module (hnh util object) + :use-module ((srfi srfi-1) :select (append-map!)) :use-module (srfi srfi-9 gnu) :use-module (ice-9 curried-definitions) :use-module (hnh util) @@ -42,10 +43,7 @@ (cond ((kv-ref #'(kvs ...) type:) => (lambda (type-stx) (with-syntax ((type type-stx)) - #'(unless (build-validator-body name type) - (scm-error 'wrong-type-arg "validator" - "Invalid value for `~s'. Expected ~s, got ~s" - (list (quote name) (quote type) name) #f))))) + #'(typecheck name type)))) (else #f))) ((_ name) #f))) @@ -114,9 +112,18 @@ (define (lambda*-stx field) (syntax-case field () ((name kvs ...) - (cond ((kv-ref #'(kvs ...) default:) - => (lambda (dflt) #`(name #,dflt))) - (else #'name))) + (let ((name (or (kv-ref #'(kvs ...) key:) + #'name))) + (cond ((kv-ref #'(kvs ...) default:) + => (lambda (dflt) #`(#,name #,dflt))) + (else name)))) + (name #'name))) + +(define (name-or-keyname field) + (syntax-case field () + ((name kvs ...) + (or (kv-ref #'(kvs ...) key:) + #'name)) (name #'name))) @@ -150,6 +157,12 @@ (lambda #,(map syntax-first #'(field ...)) (validator field) ...)))) (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...))) + ;; Alias fields for type validator + #,@(append-map! (lambda (f) (let ((fst (syntax-first f)) + (rst (name-or-keyname f))) + (unless (equal? fst rst) + (list #`(define #,fst #,rst))))) + #'(field ...)) ;; Type validators (validator field) ... (make-<type> #,@(map syntax-first #'(field ...))))))) |