[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/06: services: configuration: Allow disabling serialization.
|
From: |
guix-commits |
|
Subject: |
02/06: services: configuration: Allow disabling serialization. |
|
Date: |
Sat, 8 May 2021 01:06:17 -0400 (EDT) |
apteryx pushed a commit to branch master
in repository guix.
commit 3f9a12dc082b20426fc740416601b69ea1897193
Author: Maxim Cournoyer <maxim.cournoyer@gmail.com>
AuthorDate: Fri May 7 21:46:51 2021 -0400
services: configuration: Allow disabling serialization.
Serialization is not always useful, for example when deriving command line
arguments from a configuration. This change provides a way to turn it off,
which removes the need to define a bunch of dummy serialization procedures.
Credit goes to Andrew Gierth (RhodiumToad) from #guile for providing the
solution. Thank you!
* gnu/services/configuration.scm (define-configuration-helper): New
procedure.
(define-configuration) <no-serialization>: New syntactic keyword. Use it
in a
new pattern. Refactor the macro so that it makes use of the above helper
procedure.
---
gnu/services/configuration.scm | 135 ++++++++++++++++++++++-------------------
1 file changed, 73 insertions(+), 62 deletions(-)
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index f3c2dbf..612bfc9 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -98,7 +98,7 @@ does not have a default value" field kind)))
fields))
(define-syntax-rule (id ctx parts ...)
- "Assemble PARTS into a raw (unhygienic) identifier."
+ "Assemble PARTS into a raw (unhygienic) identifier."
(datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
(define-syntax define-maybe
@@ -116,69 +116,80 @@ does not have a default value" field kind)))
(define (serialize-maybe-stem field-name val)
(if (stem? val) (serialize-stem field-name val) ""))))))))
+(define (define-configuration-helper serialize? syn)
+ (syntax-case syn ()
+ ((_ stem (field (field-type def ...) doc) ...)
+ (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)
+ (if serialize?
+ (id #'stem #'serialize- type)
+ #f))
+ #'(field-type ...))))
+ #`(begin
+ (define-record-type* #,(id #'stem #'< #'stem #'>)
+ #,(id #'stem #'% #'stem)
+ #,(id #'stem #'make- #'stem)
+ #,(id #'stem #'stem #'?)
+ (%location #,(id #'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-syntax define-configuration
- (lambda (stx)
- (syntax-case stx ()
+ (lambda (s)
+ (syntax-case s (no-serialization)
+ ((_ stem (field (field-type def ...) doc) ... (no-serialization))
+ (define-configuration-helper
+ #f #'(_ stem (field (field-type def ...) doc) ...)))
((_ stem (field (field-type def ...) doc) ...)
- (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)
- (id #'stem #'serialize- type))
- #'(field-type ...))))
- #`(begin
- (define-record-type* #,(id #'stem #'< #'stem #'>)
- #,(id #'stem #'% #'stem)
- #,(id #'stem #'make- #'stem)
- #,(id #'stem #'stem #'?)
- (%location #,(id #'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-configuration-helper
+ #t #'(_ stem (field (field-type def ...) doc) ...))))))
(define (serialize-package field-name val)
"")
- branch master updated (b4ab965 -> a9a67da), guix-commits, 2021/05/08
- 03/06: services: configuration: Allow specifying a custom serializer., guix-commits, 2021/05/08
- 01/06: services: configuration: Avoid a compilation warning., guix-commits, 2021/05/08
- 02/06: services: configuration: Allow disabling serialization.,
guix-commits <=
- 04/06: services: configuration: Fix %location accessor name., guix-commits, 2021/05/08
- 05/06: services: configuration: Add tests., guix-commits, 2021/05/08
- 06/06: services: docker: Disable configuration serialization., guix-commits, 2021/05/08