diff options
| -rw-r--r-- | doc/ref/object/object.texi | 11 | ||||
| -rw-r--r-- | module/hnh/util/object.scm | 46 |
2 files changed, 48 insertions, 9 deletions
diff --git a/doc/ref/object/object.texi b/doc/ref/object/object.texi index fd9cb533..fe8afc59 100644 --- a/doc/ref/object/object.texi +++ b/doc/ref/object/object.texi @@ -82,6 +82,17 @@ Each type introduces a number of bindings, which are@footnote{ }: @end deffn +@deffn {Field Parameter} #:keyword name +Specify an alternative keyword to use for this parameter when creating +new instances of the object. Note that @var{name} should be a bare +symbol, and @emph{not} a keyword object. + +@example +(define-type (my-type) + (my-type-x keyword: x)) +@end example +@end deffn + @defun @var{<name>} [kv-args ...] Type constructor. Takes key-value arguments. Where the keys are the names of the fields. diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm index fe5d9873..af66e312 100644 --- a/module/hnh/util/object.scm +++ b/module/hnh/util/object.scm @@ -36,19 +36,39 @@ ;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f) +;; Each variable gets its own unless form, to enable better error messages (define-syntax (validator stx) (syntax-case stx () - ((_ (name kvs ...)) + ;; This form may be expanded both from the constructor, and from + ;; accessor procedures. + ;; In the constructor a different name may be used for the variable, + ;; due to custom keyword arguments being a thing. + ;; The field `name*' represents the variable holding the value + ;; While the field `name' contains the true name of the field in the struct. + ((_ name* (name kvs ...)) (cond ((kv-ref #'(kvs ...) type:) => (lambda (type-stx) (with-syntax ((type type-stx)) - #'(unless (build-validator-body name type) + #'(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))))) + (list (quote name) (quote type) name*) #f))))) (else #f))) ((_ name) #f))) +;;; When constructing a validator from a type constructor the keyword: +;;; key in the field declaration should be honored. This means that the +;;; looked at name, and the "true name" of a field may differ. +(define-syntax (constructor-validator stx) + (syntax-case stx () + ((_ (name kvs ...)) + (with-syntax ((name* + (cond ((kv-ref #'(kvs ...) keyword:) + => identity) + (else #'name)))) + #'(validator name* (name kvs ...)))) + ((_ name) #f))) + @@ -105,18 +125,26 @@ ;; the field. This ensures those two are the same for validator, ;; while keeping name bound to the accessor in the outer scope. (let ((name new-value)) - (validator (name kvs ...))) + (validator name (name kvs ...))) ((field-set type-name name) datum new-value))))) ((_ type-name name) #'(build-accessor type-name (name))))) +(define (syntax-name field) + (syntax-case field () + ((name kvs ...) + (cond ((kv-ref #'(kvs ...) keyword:) + => identity) + (else #'name))) + (name #'name))) + ;; Go from my concept of field deffinitions, to what lambda* wants as arguments (define (lambda*-stx field) (syntax-case field () ((name kvs ...) (cond ((kv-ref #'(kvs ...) default:) - => (lambda (dflt) #`(name #,dflt))) - (else #'name))) + => (lambda (dflt) #`(#,(syntax-name field) #,dflt))) + (else (syntax-name field)))) (name #'name))) @@ -150,11 +178,11 @@ make-<type> ;; Type validator (lambda #,(map syntax-first #'(field ...)) - (validator field) ...)))) + (constructor-validator field) ...)))) (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...))) ;; Type validators - (validator field) ... - (make-<type> #,@(map syntax-first #'(field ...))))))) + (constructor-validator field) ... + (make-<type> #,@(map syntax-name #'(field ...))))))) ;; Field accessors (build-accessor name field) ... |