@@ -124,6 +124,7 @@ (define-record-type* <configuration-field>
(predicate configuration-field-predicate)
(sanitizer configuration-field-sanitizer)
(serializer configuration-field-serializer)
+ (serializer-kwargs configuration-field-serializer-kwargs)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
@@ -139,9 +140,13 @@ (define (base-transducer config)
config)))
(maybe-value-set? field-value))))
(tmap (lambda (field)
- ((configuration-field-serializer field)
- (configuration-field-name field)
- ((configuration-field-getter field) config))))))
+ (let ((serializer (configuration-field-serializer field))
+ (field-name (configuration-field-name field))
+ (value
+ ((configuration-field-getter field) config))
+ (serializer-kwargs
+ (configuration-field-serializer-kwargs field)))
+ (apply serializer field-name value serializer-kwargs))))))
(define (serialize-configuration config fields)
#~(string-append
@@ -168,10 +173,9 @@ (define (define-maybe-helper serialize? prefix syn)
(or (not (maybe-value-set? val))
(stem? val)))
#,@(if serialize?
- (list #'(define (serialize-maybe-stem field-name val)
- (if (stem? val)
- (serialize-stem field-name val)
- "")))
+ (list #'(define (serialize-maybe-stem field-name val . rest)
+ (when (maybe-value-set? val)
+ (apply serialize-stem field-name val rest))))
'()))))))
(define-syntax define-maybe
@@ -205,38 +209,49 @@ (define (define-configuration-helper serialize? serializer-prefix syn)
"Extract and normalize arguments following @var{doc}."
(let loop ((s s)
(sanitizer* #f)
- (serializer* #f))
- (syntax-case s (sanitizer serializer empty-serializer)
+ (serializer* #f)
+ (serializer-kwargs* #f))
+ (syntax-case s (sanitizer serializer empty-serializer serializer-kwargs)
(((sanitizer proc) tail ...)
(if sanitizer*
(syntax-violation 'sanitizer
"duplicate entry" #'proc)
- (loop #'(tail ...) #'proc serializer*)))
+ (loop #'(tail ...)
+ #'proc serializer* serializer-kwargs*)))
(((serializer proc) tail ...)
(if serializer*
(syntax-violation 'serializer
"duplicate or conflicting entry" #'proc)
- (loop #'(tail ...) sanitizer* #'proc)))
+ (loop #'(tail ...)
+ sanitizer* #'proc serializer-kwargs*)))
((empty-serializer tail ...)
(if serializer*
(syntax-violation 'empty-serializer
"duplicate or conflicting entry" #f)
- (loop #'(tail ...) sanitizer* #'empty-serializer)))
+ (loop #'(tail ...)
+ sanitizer* #'empty-serializer #f)))
+ (((serializer-kwargs args) tail ...)
+ (if serializer-kwargs*
+ (syntax-violation 'serializer-kwargs
+ "duplicate or conflicting entry" #f)
+ (loop #'(tail ...)
+ sanitizer* serializer* #'args)))
(() ; stop condition
- (values (list sanitizer* serializer*)))
+ (values (list sanitizer* serializer*
+ (or serializer-kwargs* #'(quote ())))))
((proc) ; TODO: deprecated, to be removed.
- (every not (list sanitizer* serializer*))
+ (every not (list sanitizer* serializer* serializer-kwargs*))
(begin
(warning #f (G_ "specifying serializers after documentation is \
deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
- (values (list #f #'proc)))))))
+ (values (list #f #'proc #'(quote ()))))))))
(syntax-case syn ()
((_ stem (field field-type+def doc extra-args ...) ...)
(with-syntax
((((field-type def) ...)
(map normalize-field-type+def #'(field-type+def ...)))
- (((sanitizer* serializer*) ...)
+ (((sanitizer* serializer* serializer-kwargs*) ...)
(map normalize-extra-args #'((extra-args ...) ...))))
(with-syntax
(((field-getter ...)
@@ -322,6 +337,7 @@ (define (define-configuration-helper serialize? serializer-prefix syn)
(or field-sanitizer
(id #'stem #'validate- #'stem #'- #'field)))
(serializer field-serializer)
+ (serializer-kwargs serializer-kwargs*)
(default-value-thunk
(lambda ()
(if (maybe-value-set? (syntax->datum field-default))
@@ -297,6 +297,40 @@ (define (sanitize-port value)
(lambda _ "lorem")
(sanitizer (lambda () #t)))))))
+(test-group "Serializer keyword arguments"
+ (define* (serialize-port field value #:key host)
+ (format #f "host=~a,port=~d" host value))
+
+ (define-configuration kwarg-config
+ (port
+ (port 80)
+ "Lorem Ipsum."
+ (serializer-kwargs '(#:host "[2001:db8::1]"))))
+
+ (test-equal "keyword argument provided"
+ "host=[2001:db8::1],port=80"
+ (eval-gexp
+ (serialize-configuration (kwarg-config)
+ kwarg-config-fields))))
+
+(test-group "Serializer keyword arguments, define-maybe"
+ (define* (serialize-port field value #:key host)
+ (format #f "host=~a,port=~d" host value))
+
+ (define-maybe port)
+
+ (define-configuration kwarg-config
+ (port
+ (maybe-port 80)
+ "Lorem Ipsum."
+ (serializer-kwargs '(#:host "[2001:db8::1]"))))
+
+ (test-equal "keyword argument provided, maybe type"
+ "host=[2001:db8::1],port=80"
+ (eval-gexp
+ (serialize-configuration (kwarg-config)
+ kwarg-config-fields))))
+
;;;
;;; define-maybe macro.