[bug#63985] [PATCH RFC 0/5] Generic INI serializer & SRFI-171 for define-configuration

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

Hi Bruno,

Bruno Victal <mirai@makinata.eu> writes:

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

Interesting!

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

Could you offer some of your perspective as to why you preferred that
approach compared to generating multiple, tailored for use, serializers,
possibly created via a procedure?  Was there a problem with doing so, or
what is less readable, etc.?

-- 
Thanks,
Maxim