@@ -50,6 +50,7 @@ (define-module (gnu services configuration)
configuration-field-error
configuration-field-sanitizer
configuration-field-serializer
+ configuration-field-serializer-options
configuration-field-getter
configuration-field-default-value-thunk
configuration-field-documentation
@@ -127,6 +128,7 @@ (define-record-type* <configuration-field>
(predicate configuration-field-predicate)
(sanitizer configuration-field-sanitizer)
(serializer configuration-field-serializer)
+ (serializer-options configuration-field-serializer-options)
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
@@ -144,9 +146,13 @@ (define (base-transducer config)
;; Only serialize fields whose value isn't '%unset-marker%.
(tfilter-maybe-value config)
(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-options
+ (configuration-field-serializer-options field)))
+ (apply serializer field-name value serializer-options))))))
(define (serialize-configuration config fields)
#~(string-append
@@ -173,10 +179,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
@@ -210,38 +215,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-options* #f))
+ (syntax-case s (sanitizer serializer empty-serializer serializer-options)
(((sanitizer proc) tail ...)
(if sanitizer*
(syntax-violation 'sanitizer
"duplicate entry" #'proc)
- (loop #'(tail ...) #'proc serializer*)))
+ (loop #'(tail ...)
+ #'proc serializer* serializer-options*)))
(((serializer proc) tail ...)
(if serializer*
(syntax-violation 'serializer
"duplicate or conflicting entry" #'proc)
- (loop #'(tail ...) sanitizer* #'proc)))
+ (loop #'(tail ...)
+ sanitizer* #'proc serializer-options*)))
((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-options args) tail ...)
+ (if serializer-options*
+ (syntax-violation 'serializer-options
+ "duplicate or conflicting entry" #f)
+ (loop #'(tail ...)
+ sanitizer* serializer* #'args)))
(() ; stop condition
- (values (list sanitizer* serializer*)))
+ (values (list sanitizer* serializer*
+ (or serializer-options* #'(quote ())))))
((proc) ; TODO: deprecated, to be removed.
- (every not (list sanitizer* serializer*))
+ (every not (list sanitizer* serializer* serializer-options*))
(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-options*) ...)
(map normalize-extra-args #'((extra-args ...) ...))))
(with-syntax
(((field-getter ...)
@@ -327,6 +343,7 @@ (define (define-configuration-helper serialize? serializer-prefix syn)
(or field-sanitizer
(id #'stem #'validate- #'stem #'- #'field)))
(serializer field-serializer)
+ (serializer-options serializer-options*)
(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-options '(#: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-options '(#: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.