From e7c797f3481a35905a5861059294815b2210f889 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <m.othacehe@gmail.com>
Date: Fri, 24 Mar 2017 11:00:13 +0100
Subject: services: Factorize define-maybe macro.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* 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>
---
 gnu/services/configuration.scm | 34 ++++++++++++++++++++++++++--------
 1 file changed, 26 insertions(+), 8 deletions(-)

(limited to 'gnu/services/configuration.scm')

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 2ad3a637a4..400f231b94 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 @@ (define-module (gnu services configuration)
             configuration-field-default-value-thunk
             configuration-field-documentation
             serialize-configuration
+            define-maybe
             define-configuration
             validate-configuration
             generate-documentation
@@ -85,16 +87,32 @@ (define (validate-configuration config fields)
                    (configuration-field-name field) val))))
             fields))
 
+(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))))))))
+
+(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 ...)
-- 
cgit v1.2.3