mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-02-07 19:39:34 +01:00
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.
This commit is contained in:
parent
1a2704add3
commit
3f9a12dc08
1 changed files with 73 additions and 62 deletions
|
@ -98,7 +98,7 @@ does not have a default value" field kind)))
|
||||||
fields))
|
fields))
|
||||||
|
|
||||||
(define-syntax-rule (id ctx parts ...)
|
(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) ...)))
|
(datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
|
||||||
|
|
||||||
(define-syntax define-maybe
|
(define-syntax define-maybe
|
||||||
|
@ -116,69 +116,80 @@ does not have a default value" field kind)))
|
||||||
(define (serialize-maybe-stem field-name val)
|
(define (serialize-maybe-stem field-name val)
|
||||||
(if (stem? val) (serialize-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
|
(define-syntax define-configuration
|
||||||
(lambda (stx)
|
(lambda (s)
|
||||||
(syntax-case stx ()
|
(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) ...)
|
((_ stem (field (field-type def ...) doc) ...)
|
||||||
(with-syntax (((field-getter ...)
|
(define-configuration-helper
|
||||||
(map (lambda (field)
|
#t #'(_ stem (field (field-type def ...) doc) ...))))))
|
||||||
(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 (serialize-package field-name val)
|
(define (serialize-package field-name val)
|
||||||
"")
|
"")
|
||||||
|
|
Loading…
Add table
Reference in a new issue