diff options
Diffstat (limited to 'gnu/services/configuration.scm')
| -rw-r--r-- | gnu/services/configuration.scm | 81 |
1 files changed, 63 insertions, 18 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 367b85c1be..d2b1687496 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -42,6 +42,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-171) #:export (configuration-field configuration-field-name configuration-field-type @@ -59,6 +60,10 @@ define-configuration/no-serialization no-serialization + empty-serializer? + tfilter-maybe-value + base-transducer + serialize-configuration define-maybe define-maybe/no-serialization @@ -75,7 +80,9 @@ interpose list-of + list-of-packages? list-of-strings? + list-of-symbols? alist? serialize-file-like text-config? @@ -125,13 +132,36 @@ does not have a default value" field kind))) (default-value-thunk configuration-field-default-value-thunk) (documentation configuration-field-documentation)) +(define (empty-serializer? field) + "Predicate that checks whether FIELD is exempt from serialization." + (eq? empty-serializer + (configuration-field-serializer field))) + +(define (tfilter-maybe-value config) + "Return a transducer for CONFIG that removes all maybe-type fields whose +value is '%unset-marker." + (tfilter (lambda (field) + (let ((field-value ((configuration-field-getter field) config))) + (maybe-value-set? field-value))))) + +(define (base-transducer config) + "Return a transducer for CONFIG that calls the serializing procedures only +for fields marked for serialization and whose values are not '%unset-marker." + (compose (tremove empty-serializer?) + ;; Only serialize fields whose value isn't '%unset-marker%. + (tfilter-maybe-value config) + (tmap (lambda (field) + ((configuration-field-serializer field) + (configuration-field-name field) + ((configuration-field-getter field) config)))))) + (define (serialize-configuration config fields) + "Return a G-expression that contains the values corresponding to the +FIELDS of CONFIG, a record that has been generated by `define-configuration'. +The G-expression can then be serialized to disk by using something like +`mixed-text-file'." #~(string-append - #$@(map (lambda (field) - ((configuration-field-serializer field) - (configuration-field-name field) - ((configuration-field-getter field) config))) - fields))) + #$@(list-transduce (base-transducer config) rcons fields))) (define-syntax-rule (id ctx parts ...) "Assemble PARTS into a raw (unhygienic) identifier." @@ -190,32 +220,32 @@ does not have a default value" field kind))) (define (normalize-extra-args s) "Extract and normalize arguments following @var{doc}." (let loop ((s s) - (sanitizer* %unset-value) - (serializer* %unset-value)) + (sanitizer* #f) + (serializer* #f)) (syntax-case s (sanitizer serializer empty-serializer) (((sanitizer proc) tail ...) - (if (maybe-value-set? sanitizer*) - (syntax-violation 'sanitizer "duplicate entry" - #'proc) + (if sanitizer* + (syntax-violation 'sanitizer + "duplicate entry" #'proc) (loop #'(tail ...) #'proc serializer*))) (((serializer proc) tail ...) - (if (maybe-value-set? serializer*) - (syntax-violation 'serializer "duplicate or conflicting entry" - #'proc) + (if serializer* + (syntax-violation 'serializer + "duplicate or conflicting entry" #'proc) (loop #'(tail ...) sanitizer* #'proc))) ((empty-serializer tail ...) - (if (maybe-value-set? serializer*) + (if serializer* (syntax-violation 'empty-serializer "duplicate or conflicting entry" #f) (loop #'(tail ...) sanitizer* #'empty-serializer))) (() ; stop condition (values (list sanitizer* serializer*))) ((proc) ; TODO: deprecated, to be removed. - (null? (filter-map maybe-value-set? (list sanitizer* serializer*))) + (not (or sanitizer* serializer*)) (begin (warning #f (G_ "specifying serializers after documentation is \ deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc)) - (values (list %unset-value #'proc))))))) + (values (list #f #'proc))))))) (syntax-case syn () ((_ stem (field field-type+def doc extra-args ...) ...) @@ -239,11 +269,11 @@ deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc)) default-value)) #'((field-type def) ...))) ((field-sanitizer ...) - (map maybe-value #'(sanitizer* ...))) + #'(sanitizer* ...)) ((field-serializer ...) (map (lambda (type proc) (and serialize? - (or (maybe-value proc) + (or proc (if serializer-prefix (id #'stem serializer-prefix #'serialize- type) (id #'stem #'serialize- type))))) @@ -472,6 +502,11 @@ DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values." (cons delimiter acc)))) '() ls)) + +;;; +;;; Commonly used predicates +;;; + (define (list-of pred?) "Return a procedure that takes a list and check if all the elements of the list result in @code{#t} when applying PRED? on them." @@ -480,10 +515,20 @@ the list result in @code{#t} when applying PRED? on them." (every pred? x) #f))) +(define list-of-packages? + (list-of package?)) (define list-of-strings? (list-of string?)) +(define list-of-symbols? + (list-of symbol?)) + + +;;; +;;; Special serializers +;;; + (define alist? (list-of pair?)) |