diff options
| -rw-r--r-- | gnu/services/configuration.scm | 135 |
1 files changed, 73 insertions, 62 deletions
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index f3c2dbf672..612bfc9e2e 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -98,7 +98,7 @@ does not have a default value" field kind))) 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 @@ does not have a default value" field kind))) (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) "") |