services: configuration: Support fields without default values.
Not all fields in a configuration have a sensible default value. This changes makes it possible to omit a default value for a configuration field, requiring the user to provide a value. * gnu/services/configuration.scm (configuration-missing-field): New procedure. (define-configuration): Make default value optional. Signed-off-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
This commit is contained in:
parent
7ae9ef3b54
commit
d1caabbce7
|
@ -2,6 +2,7 @@
|
||||||
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
|
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
|
||||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||||
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
|
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
|
||||||
|
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -63,6 +64,10 @@ (define (configuration-field-error field val)
|
||||||
(define (configuration-missing-field kind field)
|
(define (configuration-missing-field kind field)
|
||||||
(configuration-error
|
(configuration-error
|
||||||
(format #f "~a configuration missing required field ~a" kind field)))
|
(format #f "~a configuration missing required field ~a" kind field)))
|
||||||
|
(define (configuration-no-default-value kind field)
|
||||||
|
(configuration-error
|
||||||
|
(format #f "The field `~a' of the `~a' configuration record \
|
||||||
|
does not have a default value" field kind)))
|
||||||
|
|
||||||
(define-record-type* <configuration-field>
|
(define-record-type* <configuration-field>
|
||||||
configuration-field make-configuration-field configuration-field?
|
configuration-field make-configuration-field configuration-field?
|
||||||
|
@ -112,7 +117,7 @@ (define (serialize-maybe-stem field-name val)
|
||||||
(define-syntax define-configuration
|
(define-syntax define-configuration
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
((_ stem (field (field-type def) doc) ...)
|
((_ stem (field (field-type def ...) doc) ...)
|
||||||
(with-syntax (((field-getter ...)
|
(with-syntax (((field-getter ...)
|
||||||
(map (lambda (field)
|
(map (lambda (field)
|
||||||
(id #'stem #'stem #'- field))
|
(id #'stem #'stem #'- field))
|
||||||
|
@ -121,36 +126,57 @@ (define-syntax define-configuration
|
||||||
(map (lambda (type)
|
(map (lambda (type)
|
||||||
(id #'stem type #'?))
|
(id #'stem type #'?))
|
||||||
#'(field-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 ...)
|
((field-serializer ...)
|
||||||
(map (lambda (type)
|
(map (lambda (type)
|
||||||
(id #'stem #'serialize- type))
|
(id #'stem #'serialize- type))
|
||||||
#'(field-type ...))))
|
#'(field-type ...))))
|
||||||
#`(begin
|
#`(begin
|
||||||
(define-record-type* #,(id #'stem #'< #'stem #'>)
|
(define-record-type* #,(id #'stem #'< #'stem #'>)
|
||||||
#,(id #'stem #'% #'stem)
|
#,(id #'stem #'% #'stem)
|
||||||
#,(id #'stem #'make- #'stem)
|
#,(id #'stem #'make- #'stem)
|
||||||
#,(id #'stem #'stem #'?)
|
#,(id #'stem #'stem #'?)
|
||||||
(%location #,(id #'stem #'-location)
|
(%location #,(id #'stem #'-location)
|
||||||
(default (and=> (current-source-location)
|
(default (and=> (current-source-location)
|
||||||
source-properties->location))
|
source-properties->location))
|
||||||
(innate))
|
(innate))
|
||||||
(field field-getter (default def))
|
#,@(map (lambda (name getter def)
|
||||||
...)
|
(if (eq? (syntax->datum def) (quote 'undefined))
|
||||||
(define #,(id #'stem #'stem #'-fields)
|
#`(#,name #,getter)
|
||||||
(list (configuration-field
|
#`(#,name #,getter (default #,def))))
|
||||||
(name 'field)
|
#'(field ...)
|
||||||
(type 'field-type)
|
#'(field-getter ...)
|
||||||
(getter field-getter)
|
#'(field-default ...)))
|
||||||
(predicate field-predicate)
|
(define #,(id #'stem #'stem #'-fields)
|
||||||
(serializer field-serializer)
|
(list (configuration-field
|
||||||
(default-value-thunk (lambda () def))
|
(name 'field)
|
||||||
(documentation doc))
|
(type 'field-type)
|
||||||
...))
|
(getter field-getter)
|
||||||
(define-syntax-rule (stem arg (... ...))
|
(predicate field-predicate)
|
||||||
(let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
|
(serializer field-serializer)
|
||||||
(validate-configuration conf
|
(default-value-thunk
|
||||||
#,(id #'stem #'stem #'-fields))
|
(lambda ()
|
||||||
conf))))))))
|
(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…
Reference in a new issue