services: configuration: Support (field1 maybe-number "") format.

As opposed to explicitly using 'disabled as value, or using the
(field1 (maybe-number) "") format.

It's mostly the work of Maxime Devos shared under #54674, with some
modifications by Attila Lendvai.

* gnu/services/configuration.scm (normalize-field-type+def): New function.
(define-configuration-helper) (define-configuration): Support new field
format.
* tests/services/configuration.scm (config-with-maybe-number->string): New
function.
("maybe value serialization of the instance"): New test.
("maybe value serialization of the instance, unspecified"): New test.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 114 insertions, 83 deletions

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 0de350a4df..bdca33ed68 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -162,78 +163,90 @@ does not have a default value" field kind)))
 (define-syntax-rule (define-maybe/no-serialization stem)
   (define-maybe stem (no-serialization)))
 
+(define (normalize-field-type+def s)
+  (syntax-case s ()
+    ((field-type def)
+     (identifier? #'field-type)
+     (values #'(field-type def)))
+    ((field-type)
+     (identifier? #'field-type)
+     (values #'(field-type 'disabled)))
+    (field-type
+     (identifier? #'field-type)
+     (values #'(field-type 'disabled)))))
+
 (define (define-configuration-helper serialize? serializer-prefix syn)
   (syntax-case syn ()
-    ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
-     (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 custom-serializer)
-                           (and serialize?
-                                (match custom-serializer
-                                  ((serializer)
-                                   serializer)
-                                  (()
-                                   (if serializer-prefix
-                                       (id #'stem
-                                           serializer-prefix
-                                           #'serialize- type)
-                                       (id #'stem #'serialize- type))))))
-                         #'(field-type ...)
-                         #'((custom-serializer ...) ...))))
-       #`(begin
-    	   (define-record-type* #,(id #'stem #'< #'stem #'>)
-    	     #,(id #'stem #'% #'stem)
-    	     #,(id #'stem #'make- #'stem)
-    	     #,(id #'stem #'stem #'?)
-    	     (%location #,(id #'stem #'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)))))))
+    ((_ stem (field field-type+def doc custom-serializer ...) ...)
+     (with-syntax
+         ((((field-type def) ...)
+           (map normalize-field-type+def #'(field-type+def ...))))
+       (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 def) ...)))
+            ((field-serializer ...)
+             (map (lambda (type custom-serializer)
+                    (and serialize?
+                         (match custom-serializer
+                           ((serializer)
+                            serializer)
+                           (()
+                            (if serializer-prefix
+                                (id #'stem
+                                    serializer-prefix
+                                    #'serialize- type)
+                                (id #'stem #'serialize- type))))))
+                  #'(field-type ...)
+                  #'((custom-serializer ...) ...))))
+         #`(begin
+             (define-record-type* #,(id #'stem #'< #'stem #'>)
+               #,(id #'stem #'% #'stem)
+               #,(id #'stem #'make- #'stem)
+               #,(id #'stem #'stem #'?)
+               (%location #,(id #'stem #'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 no-serialization         ;syntactic keyword for 'define-configuration'
   '(no serialization))
@@ -241,26 +254,26 @@ does not have a default value" field kind)))
 (define-syntax define-configuration
   (lambda (s)
     (syntax-case s (no-serialization prefix)
-      ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
+      ((_ stem (field field-type+def doc custom-serializer ...) ...
           (no-serialization))
        (define-configuration-helper
-         #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
+         #f #f #'(_ stem (field field-type+def doc custom-serializer ...)
                  ...)))
-      ((_ stem  (field (field-type def ...) doc custom-serializer ...) ...
+      ((_ stem  (field field-type+def doc custom-serializer ...) ...
           (prefix serializer-prefix))
        (define-configuration-helper
-         #t #'serializer-prefix #'(_ stem (field (field-type def ...)
+         #t #'serializer-prefix #'(_ stem (field field-type+def
                                                  doc custom-serializer ...)
                  ...)))
-      ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
+      ((_ stem (field field-type+def doc custom-serializer ...) ...)
        (define-configuration-helper
-         #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
+         #t #f #'(_ stem (field field-type+def doc custom-serializer ...)
                  ...))))))
 
 (define-syntax-rule (define-configuration/no-serialization
-                      stem (field (field-type def ...)
+                      stem (field field-type+def
                                   doc custom-serializer ...) ...)
-  (define-configuration stem (field (field-type def ...)
+  (define-configuration stem (field field-type+def
                                     doc custom-serializer ...) ...
     (no-serialization)))
 
diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm
index 86a36a388d..0debf8095b 100644
--- a/tests/services/configuration.scm
+++ b/tests/services/configuration.scm
@@ -27,6 +27,9 @@
 
 (test-begin "services-configuration")
 
+(define (serialize-number field value)
+  (format #f "~a=~a" field value))
+
 
 ;;;
 ;;; define-configuration macro.
@@ -47,7 +50,6 @@
   80
   (port-configuration-cs-port (port-configuration-cs)))
 
-(define serialize-number "")
 (define-configuration port-configuration-ndv
   (port (number) "The port number."))
 
@@ -101,15 +103,31 @@
 (define-maybe number)
 
 (define-configuration config-with-maybe-number
-  (port (maybe-number 80) "The port number."))
-
-(define (serialize-number field value)
-  (format #f "~a=~a" field value))
+  (port  (maybe-number 80) "")
+  (count maybe-number ""))
 
 (test-equal "maybe value serialization"
   "port=80"
   (serialize-maybe-number "port" 80))
 
+(define (config-with-maybe-number->string x)
+  (eval (gexp->approximate-sexp
+         (serialize-configuration x config-with-maybe-number-fields))
+        (current-module)))
+
+(test-equal "maybe value serialization of the instance"
+  "port=42count=43"
+  (config-with-maybe-number->string
+   (config-with-maybe-number
+    (port 42)
+    (count 43))))
+
+(test-equal "maybe value serialization of the instance, unspecified"
+  "port=42"
+  (config-with-maybe-number->string
+   (config-with-maybe-number
+    (port 42))))
+
 (define-maybe/no-serialization string)
 
 (define-configuration config-with-maybe-string/no-serialization