[bug#63985] [PATCH v3 05/11] services: configuration: Add serializer-options field.

[Bruno Victal]

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.
* doc/guix.texi (Complex Configurations): Document serializer-options.
---
 doc/guix.texi                    | 11 +++++
 gnu/services/configuration.scm   | 49 ++++++++++++-------
 tests/services/configuration.scm | 82 ++++++++++++++++++++++++++++++++
 3 files changed, 126 insertions(+), 16 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 8355260378..14802e9366 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -42032,6 +42032,17 @@ Complex Configurations
         ((symbol? value) (symbol->string value))
         (else (error "bad value"))))
 @end lisp
+
+@item @code{(serializer-options @var{arglst})}
+@var{arglst} is a list of extra arguments that are relayed to the
+serializing procedure.  This allows for writing serialization
+procedures that take more than two arguments.
+
+An example of a serializer procedure that requires additional data:
+@lisp
+(define* (serialize-port field value #:key context)
+  #~(format #f "section=~a,port=~d" #$context #$value))
+@end lisp
 @end table
 
 In some cases multiple different configuration records might be defined
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 40a4e74b4d..8b1d1e4749 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -297,6 +297,88 @@ (define (sanitize-port value)
                     (lambda _ "lorem")
                     (sanitizer (lambda () #t)))))))
 
+(test-group "Serializer options"
+  (test-group "Serialize 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]"))))
+
+    (define-maybe port)
+    (define-configuration kwarg-maybe-config
+      (port
+       (maybe-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-equal "keyword argument provided, maybe type"
+      "host=[2001:db8::1],port=80"
+      (eval-gexp
+       (serialize-configuration (kwarg-maybe-config)
+                                kwarg-maybe-config-fields))))
+
+  (test-group "Serialize optional arguments"
+    (define* (serialize-port field-name value #:optional override-name)
+      (format #f "~a=~d" (or override-name field-name) value))
+
+    (define-configuration with-optarg
+      (port
+       (port 80)
+       "Lorem Ipsum."
+       (serializer-options '(service-port))))
+
+    (define-configuration without-optarg
+      (port
+       (port 80)
+       "Lorem Ipsum."))
+
+    (test-equal "optional argument, provided"
+      "service-port=80"
+      (eval-gexp (serialize-configuration (with-optarg)
+                                          with-optarg-fields)))
+
+    (test-equal "optional argument, absent"
+      "port=80"
+      (eval-gexp (serialize-configuration (without-optarg)
+                                          without-optarg-fields))))
+
+  (test-group "Serialize optional & keyword arguments"
+    (define* (serialize-port field-name value #:optional override-name
+                             #:key host)
+      (format #f "host=~a,~a=~d" host (or override-name field-name) value))
+
+    (define-configuration mixed-args
+      (port
+       (port 80)
+       "Lorem Ipsum."
+       (serializer-options '(service-port #:host "example.com"))))
+
+    (define-configuration mixed-no-optarg
+      (port
+       (port 80)
+       "Lorem Ipsum."
+       (serializer-options '(#:host "example.com"))))
+
+    (test-equal "mixed arguments, optional provided"
+      "host=example.com,service-port=80"
+      (eval-gexp (serialize-configuration (mixed-args)
+                                          mixed-args-fields)))
+
+    (test-equal "mixed arguments, optional absent"
+      "host=example.com,port=80"
+      (eval-gexp (serialize-configuration (mixed-no-optarg)
+                                          mixed-no-optarg-fields)))))
+
 
 ;;;
 ;;; define-maybe macro.
-- 
2.39.2