[bug#63985] [PATCH RFC v2 4/5] services: configuration: Add serializer-options field.

[Bruno Victal <mirai@makinata.eu>]

Allow relaying additional arguments to a serialize-<type> procedure.

* gnu/services/configuration.scm (configuration-field)
<serializer-options>: New field.
(base-transducer, define-maybe-helper): Adjust to relay additional arguments.
(normalize-extra-args): Implement serializer-options literal.

* tests/services/configuration.scm: Add tests for serializer-options.
---
 gnu/services/configuration.scm   | 49 +++++++++++++++++++++-----------
 tests/services/configuration.scm | 34 ++++++++++++++++++++++
 2 files changed, 67 insertions(+), 16 deletions(-)

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index cd2cb8318b..4eee5a26c2 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -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))
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 1db83bb273..d23a0cde89 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -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))))
+
 \f
 ;;;
 ;;; define-maybe macro.
-- 
2.39.2