services: Factorize define-maybe macro.
* gnu/services/configuration.scm (id): New procedure extracted from define-configuration. (define-maybe): New exported procedure, moved from messaging.scm. * gnu/services/messaging.scm (define-maybe): Remove it. (id): Move declaration inside define-all-configurations which is now the only caller procedure. Signed-off-by: Clément Lassieur <clement@lassieur.org>master
parent
32e75b4808
commit
e7c797f348
|
@ -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,9 +87,7 @@
|
|||
(configuration-field-name field) val))))
|
||||
fields))
|
||||
|
||||
(define-syntax define-configuration
|
||||
(lambda (stx)
|
||||
(define (id ctx part . parts)
|
||||
(define (id ctx part . parts)
|
||||
(let ((part (syntax->datum part)))
|
||||
(datum->syntax
|
||||
ctx
|
||||
|
@ -95,6 +95,24 @@
|
|||
(() part)
|
||||
(parts (symbol-append part
|
||||
(syntax->datum (apply id ctx 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)
|
||||
(syntax-case stx ()
|
||||
((_ stem (field (field-type def) doc) ...)
|
||||
(with-syntax (((field-getter ...)
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
|
||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
@ -49,27 +50,11 @@
|
|||
;;;
|
||||
;;; Code:
|
||||
|
||||
(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-all-configurations
|
||||
(lambda (stx)
|
||||
(define-syntax-rule (id ctx parts ...)
|
||||
"Assemble PARTS into a raw (unhygienic) identifier."
|
||||
(datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
|
||||
(define (make-pred arg)
|
||||
(lambda (field target)
|
||||
(and (memq (syntax->datum target) `(common ,arg)) field)))
|
||||
|
|
Reference in New Issue