diff options
| author | Leo Famulari <leo@famulari.name> | 2017-03-27 21:19:38 -0400 |
|---|---|---|
| committer | Leo Famulari <leo@famulari.name> | 2017-03-27 21:19:38 -0400 |
| commit | c17383f400d3b942c22ec46b556cad8ca3a2fce1 (patch) | |
| tree | f430fdc7b6e41a652b4a0dbdd08050f586e4b24d /gnu/services/configuration.scm | |
| parent | b1a8fd2d2cf6bf1b20ba8d26ca6f9a7caef60cbc (diff) | |
| parent | 7aeb4ffa5828206f89ec62226863c27f7c1c028d (diff) | |
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu/services/configuration.scm')
| -rw-r--r-- | gnu/services/configuration.scm | 29 |
1 files changed, 21 insertions, 8 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 2ad3a637a4..0a2219e743 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,6 +37,7 @@ configuration-field-default-value-thunk configuration-field-documentation serialize-configuration + define-maybe define-configuration validate-configuration generate-documentation @@ -85,16 +87,27 @@ (configuration-field-name field) val)))) fields)) +(define-syntax-rule (id ctx parts ...) + "Assemble PARTS into a raw (unhygienic) identifier." + (datum->syntax ctx (symbol-append (syntax->datum parts) ...))) + +(define-syntax define-maybe + (lambda (x) + (syntax-case x () + ((_ 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) + (when (stem? val) (serialize-stem field-name val))))))))) + (define-syntax define-configuration (lambda (stx) - (define (id ctx part . parts) - (let ((part (syntax->datum part))) - (datum->syntax - ctx - (match parts - (() part) - (parts (symbol-append part - (syntax->datum (apply id ctx parts)))))))) (syntax-case stx () ((_ stem (field (field-type def) doc) ...) (with-syntax (((field-getter ...) |