ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 15:36:20 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

services: configuration: Allow disabling serialization.

Browse source 
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 2021-05-07 21:46:51 -04:00
parent 1a2704add3
commit 3f9a12dc08
No known key found for this signature in database
GPG key ID: 1260E46482E63562
1 changed files with 73 additions and 62 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

135
gnu/services/configuration.scm
View file

@ -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)
"")