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:
Maxim Cournoyer
parent
1a2704add3
commit
3f9a12dc08
|
|
@ -98,7 +98,7 @@ (define (validate-configuration config fields)
|
|||
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 @@ (define (maybe-stem? val)
|
|||
(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)
|
||||
"")
|
||||
|
|
|
|||
Loading…
Reference in a new issue