services: configuration: Allow disabling serialization.

Serialization is not always useful, for example when deriving command line
arguments from a configuration.  This change provides a way to turn it off,
which removes the need to define a bunch of dummy serialization procedures.

Credit goes to Andrew Gierth (RhodiumToad) from #guile for providing the
solution.  Thank you!

* gnu/services/configuration.scm (define-configuration-helper): New procedure.
(define-configuration) <no-serialization>: New syntactic keyword.  Use it in a
new pattern.  Refactor the macro so that it makes use of the above helper
procedure.

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)
   "")