Introduce keyword: to define-type.

Type fields like to be named after their containing type. But when
creating new instances having to type the full name each time gets
cumbersome. This allows local keywords for cleaner code.

1 files changed, 37 insertions, 9 deletions

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) ...