aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/services/configuration.scm169
-rw-r--r--tests/services/configuration.scm28
2 files changed, 114 insertions, 83 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 0de350a4df..bdca33ed68 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -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)))
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 86a36a388d..0debf8095b 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -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
generated by cgit