aboutsummaryrefslogtreecommitdiff
path: root/gnu/services/configuration.scm
diff options
context:
space:
mode:
authorMaxim Cournoyer <maxim.cournoyer@gmail.com>2021-05-07 21:46:51 -0400
committerMaxim Cournoyer <maxim.cournoyer@gmail.com>2021-05-08 00:50:39 -0400
commit3f9a12dc082b20426fc740416601b69ea1897193 (patch)
tree5cdb641aa666726334cbafb83cae18c281029479 /gnu/services/configuration.scm
parent1a2704add3be3938501083bdb7c74367a9fd7d81 (diff)
downloadguix-3f9a12dc082b20426fc740416601b69ea1897193.tar
guix-3f9a12dc082b20426fc740416601b69ea1897193.tar.gz
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.
Diffstat (limited to 'gnu/services/configuration.scm')
-rw-r--r--gnu/services/configuration.scm135
1 files changed, 73 insertions, 62 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index f3c2dbf672..612bfc9e2e 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)
"")