From da085158b30ae983cdaaf172ba2fb97b40d3207d Mon Sep 17 00:00:00 2001
From: Carlo Zancanaro <carlo@zancanaro.id.au>
Date: Sat, 13 May 2017 20:20:27 +1000
Subject: [PATCH 1/2] services: Add `define-service-type`.

* gnu/services.scm (id, define-service-type): New macros.
---
 gnu/services.scm | 33 +++++++++++++++++++++++++++++++++
 1 file changed, 33 insertions(+)

diff --git a/gnu/services.scm b/gnu/services.scm
index 5c314748d..837e75568 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -50,6 +50,8 @@
             service-type-extend
             service-type-default-value
 
+            define-service-type
+
             service
             service?
             service-kind
@@ -154,6 +156,37 @@
 
 (set-record-type-printer! <service-type> write-service-type)
 
+(define-syntax-rule (id ctx parts ...)
+  "Assemble PARTS into a raw (unhygienic)  identifier."
+  (datum->syntax ctx (symbol-append (if (symbol? parts)
+                                        parts
+                                        (syntax->datum parts)) ...)))
+
+(define-syntax define-service-type
+  (lambda (stx)
+    (syntax-case stx (extensions configuration)
+      ((define-service-type service-name
+         (extensions exts ...)
+         (configuration (fields tail ...) ...))
+       (with-syntax (((field-accessors ...)
+                      (map (lambda (field)
+                             (id #'stx #'service-name '-configuration- field))
+                           #'(fields ...))))
+         #`(begin
+             (define #,(id #'stx #'service-name '-service-type)
+               (service-type
+                (name 'service-name)
+                (extensions exts ...)))
+             (define-record-type* #,(id #'stx '< #'service-name '-configuration>)
+               #,(id #'stx #'service-name '-configuration)
+               #,(id #'stx 'make- #'service-name '-configuration)
+               #,(id #'stx #'service-name '-configuration?)
+               (fields field-accessors tail ...) ...)
+             (define-syntax-rule (#,(id #'stx #'service-name '-service) config (... ...))
+               (service
+                #,(id #'stx #'service-name '-service-type)
+                (#,(id #'stx #'service-name '-configuration) config (... ...))))))))))
+
 ;; Services of a given type.
 (define-record-type <service>
   (make-service type value)
-- 
2.12.2