aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/services/configuration.scm38
-rw-r--r--tests/services/configuration.scm12
2 files changed, 39 insertions, 11 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index f23840ee6d..fd07b6fa49 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -109,14 +109,18 @@ does not have a default value" field kind)))
"Assemble PARTS into a raw (unhygienic) identifier."
(datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
-(define (define-maybe-helper serialize? syn)
+(define (define-maybe-helper serialize? prefix syn)
(syntax-case syn ()
((_ stem)
(with-syntax
((stem? (id #'stem #'stem #'?))
(maybe-stem? (id #'stem #'maybe- #'stem #'?))
- (serialize-stem (id #'stem #'serialize- #'stem))
- (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
+ (serialize-stem (if prefix
+ (id #'stem prefix #'serialize- #'stem)
+ (id #'stem #'serialize- #'stem)))
+ (serialize-maybe-stem (if prefix
+ (id #'stem prefix #'serialize-maybe- #'stem)
+ (id #'stem #'serialize-maybe- #'stem))))
#`(begin
(define (maybe-stem? val)
(or (eq? val 'disabled) (stem? val)))
@@ -129,16 +133,18 @@ does not have a default value" field kind)))
(define-syntax define-maybe
(lambda (x)
- (syntax-case x (no-serialization)
+ (syntax-case x (no-serialization prefix)
((_ stem (no-serialization))
- (define-maybe-helper #f #'(_ stem)))
+ (define-maybe-helper #f #f #'(_ stem)))
+ ((_ stem (prefix serializer-prefix))
+ (define-maybe-helper #t #'serializer-prefix #'(_ stem)))
((_ stem)
- (define-maybe-helper #t #'(_ stem))))))
+ (define-maybe-helper #t #f #'(_ stem))))))
(define-syntax-rule (define-maybe/no-serialization stem)
(define-maybe stem (no-serialization)))
-(define (define-configuration-helper serialize? syn)
+(define (define-configuration-helper serialize? serializer-prefix syn)
(syntax-case syn ()
((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
(with-syntax (((field-getter ...)
@@ -165,7 +171,11 @@ does not have a default value" field kind)))
((serializer)
serializer)
(()
- (id #'stem #'serialize- type)))))
+ (if serializer-prefix
+ (id #'stem
+ serializer-prefix
+ #'serialize- type)
+ (id #'stem #'serialize- type))))))
#'(field-type ...)
#'((custom-serializer ...) ...))))
#`(begin
@@ -212,15 +222,21 @@ does not have a default value" field kind)))
(define-syntax define-configuration
(lambda (s)
- (syntax-case s (no-serialization)
+ (syntax-case s (no-serialization prefix)
((_ stem (field (field-type def ...) doc custom-serializer ...) ...
(no-serialization))
(define-configuration-helper
- #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 ...) ...
+ (prefix serializer-prefix))
+ (define-configuration-helper
+ #t #'serializer-prefix #'(_ stem (field (field-type def ...)
+ doc custom-serializer ...)
...)))
((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
(define-configuration-helper
- #t #'(_ 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
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 85badd2da6..86a36a388d 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -82,6 +83,17 @@
(let ((config (serializable-configuration)))
(serialize-configuration config serializable-configuration-fields)))))
+(define (custom-prefix-serialize-integer field-name name) name)
+
+(define-configuration configuration-with-prefix
+ (port (integer 10) "The port number.")
+ (prefix custom-prefix-))
+
+(test-assert "serialize-configuration with prefix"
+ (gexp?
+ (let ((config (configuration-with-prefix)))
+ (serialize-configuration config configuration-with-prefix-fields))))
+
;;;
;;; define-maybe macro.