diff options
| -rw-r--r-- | gnu/services/configuration.scm | 37 | ||||
| -rw-r--r-- | tests/services/configuration.scm | 29 |
2 files changed, 53 insertions, 13 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 21cb829382..72b1d1cec6 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -48,6 +48,7 @@ serialize-configuration define-maybe + define-maybe/no-serialization validate-configuration generate-documentation configuration->documentation @@ -107,20 +108,34 @@ does not have a default value" field kind))) "Assemble PARTS into a raw (unhygienic) identifier." (datum->syntax ctx (symbol-append (syntax->datum parts) ...))) +(define (define-maybe-helper serialize? syn) + (syntax-case syn () + ((_ stem) + (with-syntax + ((stem? (id #'stem #'stem #'?)) + (maybe-stem? (id #'stem #'maybe- #'stem #'?)) + (serialize-stem (id #'stem #'serialize- #'stem)) + (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem))) + #`(begin + (define (maybe-stem? val) + (or (eq? val 'disabled) (stem? val))) + #,@(if serialize? + (list #'(define (serialize-maybe-stem field-name val) + (if (stem? val) + (serialize-stem field-name val) + ""))) + '())))))) + (define-syntax define-maybe (lambda (x) - (syntax-case x () + (syntax-case x (no-serialization) + ((_ stem (no-serialization)) + (define-maybe-helper #f #'(_ stem))) ((_ stem) - (with-syntax - ((stem? (id #'stem #'stem #'?)) - (maybe-stem? (id #'stem #'maybe- #'stem #'?)) - (serialize-stem (id #'stem #'serialize- #'stem)) - (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem))) - #'(begin - (define (maybe-stem? val) - (or (eq? val 'disabled) (stem? val))) - (define (serialize-maybe-stem field-name val) - (if (stem? val) (serialize-stem field-name val) "")))))))) + (define-maybe-helper #t #'(_ stem)))))) + +(define-syntax-rule (define-maybe/no-serialization stem) + (define-maybe stem (no-serialization))) (define (define-configuration-helper serialize? syn) (syntax-case syn () diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm index 21ad188485..85badd2da6 100644 --- a/tests/services/configuration.scm +++ b/tests/services/configuration.scm @@ -16,7 +16,7 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. -(define-module (tests services linux) +(define-module (tests services configuration) #:use-module (gnu services configuration) #:use-module (guix gexp) #:use-module (srfi srfi-34) @@ -61,7 +61,7 @@ (port-configuration-ndv-port (port-configuration-ndv)))) (define (custom-number-serializer name value) - (format #t "~a = ~a;" name value)) + (format #f "~a = ~a;" name value)) (define-configuration serializable-configuration (port (number 80) "The port number." custom-number-serializer)) @@ -81,3 +81,28 @@ (not (false-if-exception (let ((config (serializable-configuration))) (serialize-configuration config serializable-configuration-fields))))) + + +;;; +;;; define-maybe macro. +;;; +(define-maybe number) + +(define-configuration config-with-maybe-number + (port (maybe-number 80) "The port number.")) + +(define (serialize-number field value) + (format #f "~a=~a" field value)) + +(test-equal "maybe value serialization" + "port=80" + (serialize-maybe-number "port" 80)) + +(define-maybe/no-serialization string) + +(define-configuration config-with-maybe-string/no-serialization + (name (maybe-string) "The name of the item.") + (no-serialization)) + +(test-assert "maybe value without serialization no procedure bound" + (not (defined? 'serialize-maybe-string))) |