me
/
guix
Archived
1
0
Fork 0
Code

services: configuration: Support (field1 maybe-number "") format. 

As opposed to explicitly using 'disabled as value, or using the
(field1 (maybe-number) "") format.

It's mostly the work of Maxime Devos shared under #54674, with some
modifications by Attila Lendvai.

* gnu/services/configuration.scm (normalize-field-type+def): New function.
(define-configuration-helper) (define-configuration): Support new field
format.
* tests/services/configuration.scm (config-with-maybe-number->string): New
function.
("maybe value serialization of the instance"): New test.
("maybe value serialization of the instance, unspecified"): New test.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Attila Lendvai 2022-05-17 13:39:26 +02:00 committed by Ludovic Courtès
parent 3d0749b4e3
commit e11517052b
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 114 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

169
gnu/services/configuration.scm
View File

@ -5,6 +5,7 @@
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@ -162,78 +163,90 @@ does not have a default value" field kind)))
(define-syntax-rule (define-maybe/no-serialization stem)
(define-maybe stem (no-serialization)))
(define (normalize-field-type+def s)
(syntax-case s ()
((field-type def)
(identifier? #'field-type)
(values #'(field-type def)))
((field-type)
(identifier? #'field-type)
(values #'(field-type 'disabled)))
(field-type
(identifier? #'field-type)
(values #'(field-type 'disabled)))))
(define (define-configuration-helper serialize? serializer-prefix syn)
(syntax-case syn ()
((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
(with-syntax (((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-default ...)
(map (match-lambda
((field-type default-value)
default-value)
((field-type)
;; Quote `undefined' to prevent a possibly
;; unbound warning.
(syntax 'undefined)))
#'((field-type def ...) ...)))
((field-serializer ...)
(map (lambda (type custom-serializer)
(and serialize?
(match custom-serializer
((serializer)
serializer)
(()
(if serializer-prefix
(id #'stem
serializer-prefix
#'serialize- type)
(id #'stem #'serialize- type))))))
#'(field-type ...)
#'((custom-serializer ...) ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
#,(id #'stem #'% #'stem)
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
(%location #,(id #'stem #'stem #'-location)
(default (and=> (current-source-location)
source-properties->location))
(innate))
#,@(map (lambda (name getter def)
(if (eq? (syntax->datum def) (quote 'undefined))
#`(#,name #,getter)
#`(#,name #,getter (default #,def))))
#'(field ...)
#'(field-getter ...)
#'(field-default ...)))
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk
(lambda ()
(display '#,(id #'stem #'% #'stem))
(if (eq? (syntax->datum field-default)
'undefined)
(configuration-no-default-value
'#,(id #'stem #'% #'stem) 'field)
field-default)))
(documentation doc))
...))
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf)))))))
((_ stem (field field-type+def doc custom-serializer ...) ...)
(with-syntax
((((field-type def) ...)
(map normalize-field-type+def #'(field-type+def ...))))
(with-syntax
(((field-getter ...)
(map (lambda (field)
(id #'stem #'stem #'- field))
#'(field ...)))
((field-predicate ...)
(map (lambda (type)
(id #'stem type #'?))
#'(field-type ...)))
((field-default ...)
(map (match-lambda
((field-type default-value)
default-value))
#'((field-type def) ...)))
((field-serializer ...)
(map (lambda (type custom-serializer)
(and serialize?
(match custom-serializer
((serializer)
serializer)
(()
(if serializer-prefix
(id #'stem
serializer-prefix
#'serialize- type)
(id #'stem #'serialize- type))))))
#'(field-type ...)
#'((custom-serializer ...) ...))))
#`(begin
(define-record-type* #,(id #'stem #'< #'stem #'>)
#,(id #'stem #'% #'stem)
#,(id #'stem #'make- #'stem)
#,(id #'stem #'stem #'?)
(%location #,(id #'stem #'stem #'-location)
(default (and=> (current-source-location)
source-properties->location))
(innate))
#,@(map (lambda (name getter def)
(if (eq? (syntax->datum def) (quote 'undefined))
#`(#,name #,getter)
#`(#,name #,getter (default #,def))))
#'(field ...)
#'(field-getter ...)
#'(field-default ...)))
(define #,(id #'stem #'stem #'-fields)
(list (configuration-field
(name 'field)
(type 'field-type)
(getter field-getter)
(predicate field-predicate)
(serializer field-serializer)
(default-value-thunk
(lambda ()
(display '#,(id #'stem #'% #'stem))
(if (eq? (syntax->datum field-default)
'undefined)
(configuration-no-default-value
'#,(id #'stem #'% #'stem) 'field)
field-default)))
(documentation doc))
...))
(define-syntax-rule (stem arg (... ...))
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
(validate-configuration conf
#,(id #'stem #'stem #'-fields))
conf))))))))
(define no-serialization ;syntactic keyword for 'define-configuration'
'(no serialization))
@ -241,26 +254,26 @@ does not have a default value" field kind)))
(define-syntax define-configuration
(lambda (s)
(syntax-case s (no-serialization prefix)
((_ stem (field (field-type def ...) doc custom-serializer ...) ...
((_ stem (field field-type+def doc custom-serializer ...) ...
(no-serialization))
(define-configuration-helper
#f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
#f #f #'(_ stem (field field-type+def doc custom-serializer ...)
...)))
((_ stem (field (field-type def ...) doc custom-serializer ...) ...
((_ stem (field field-type+def doc custom-serializer ...) ...
(prefix serializer-prefix))
(define-configuration-helper
#t #'serializer-prefix #'(_ stem (field (field-type def ...)
#t #'serializer-prefix #'(_ stem (field field-type+def
doc custom-serializer ...)
...)))
((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
((_ stem (field field-type+def doc custom-serializer ...) ...)
(define-configuration-helper
#t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
#t #f #'(_ stem (field field-type+def doc custom-serializer ...)
...))))))
(define-syntax-rule (define-configuration/no-serialization
stem (field (field-type def ...)
stem (field field-type+def
doc custom-serializer ...) ...)
(define-configuration stem (field (field-type def ...)
(define-configuration stem (field field-type+def
doc custom-serializer ...) ...
(no-serialization)))

28
tests/services/configuration.scm
View File

@ -27,6 +27,9 @@
(test-begin "services-configuration")
(define (serialize-number field value)
(format #f "~a=~a" field value))
;;;
;;; define-configuration macro.
@ -47,7 +50,6 @@
80
(port-configuration-cs-port (port-configuration-cs)))
(define serialize-number "")
(define-configuration port-configuration-ndv
(port (number) "The port number."))
@ -101,15 +103,31 @@
(define-maybe number)
(define-configuration config-with-maybe-number
(port (maybe-number 80) "The port number."))
(define (serialize-number field value)
(format #f "~a=~a" field value))
(port (maybe-number 80) "")
(count maybe-number ""))
(test-equal "maybe value serialization"
"port=80"
(serialize-maybe-number "port" 80))
(define (config-with-maybe-number->string x)
(eval (gexp->approximate-sexp
(serialize-configuration x config-with-maybe-number-fields))
(current-module)))
(test-equal "maybe value serialization of the instance"
"port=42count=43"
(config-with-maybe-number->string
(config-with-maybe-number
(port 42)
(count 43))))
(test-equal "maybe value serialization of the instance, unspecified"
"port=42"
(config-with-maybe-number->string
(config-with-maybe-number
(port 42))))
(define-maybe/no-serialization string)
(define-configuration config-with-maybe-string/no-serialization