From 231281ebf555295e83513873293a1ad3eab884a8 Mon Sep 17 00:00:00 2001
Message-Id: <231281ebf555295e83513873293a1ad3eab884a8.1619869705.git.public@yoctocell.xyz>
In-Reply-To: <cover.1619869705.git.public@yoctocell.xyz>
References: <cover.1619869705.git.public@yoctocell.xyz>
From: Xinglu Chen <public@yoctocell.xyz>
Date: Sat, 1 May 2021 13:24:43 +0200
Subject: [PATCH 1/2] services: configuration: Support fields without default
 values.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Not all fields in a configuration have a sensible default value,
e.g. ‘user.name’ in gitconfig, the user should have to set that themselves

* gnu/services/configuration.scm (configuration-missing-field): New procedure.
(define-configuration): Make default value optional.
---
 gnu/services/configuration.scm | 78 ++++++++++++++++++++++------------
 1 file changed, 51 insertions(+), 27 deletions(-)

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 90f12a8d39..85e1ac78cb 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -63,6 +64,9 @@
 (define (configuration-missing-field kind field)
   (configuration-error
    (format #f "~a configuration missing required field ~a" kind field)))
+(define (configuration-no-default-value kind field)
+  (configuration-error
+   (format #f "`~a' in `~a' does not have a default value" kind field)))
 
 (define-record-type* <configuration-field>
   configuration-field make-configuration-field configuration-field?
@@ -112,7 +116,7 @@
 (define-syntax define-configuration
   (lambda (stx)
     (syntax-case stx ()
-      ((_ stem (field (field-type def) doc) ...)
+      ((_ stem (field (field-type properties ...) doc) ...)
        (with-syntax (((field-getter ...)
                       (map (lambda (field)
                              (id #'stem #'stem #'- field))
@@ -121,36 +125,56 @@
                       (map (lambda (type)
                              (id #'stem type #'?))
                            #'(field-type ...)))
+                     ((field-default ...)
+                      (map (match-lambda
+                             ((field-type default _ ...) default)
+                             ;; We get warnings about `disabled' being an
+                             ;; unbound variable unless we quote it.
+                             (_ (syntax 'disabled)))
+                           #'((field-type properties ...) ...)))
                      ((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))
-                 (field field-getter (default def))
-                 ...)
-               (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 () def))
-                        (documentation doc))
-                       ...))
-               (define-syntax-rule (stem arg (... ...))
-                 (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
-                   (validate-configuration conf
-                                           #,(id #'stem #'stem #'-fields))
-                   conf))))))))
+         #`(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 (equal? (syntax->datum def) (quote 'disabled))
+                             #`(#,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)
+                      ;; TODO: What if there is no default value?
+                      (default-value-thunk
+                        (lambda ()
+                          (display '#,(id #'stem #'% #'stem))
+                          (if (equal? (syntax->datum field-default)
+                                      (quote 'disabled))
+                              (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 (serialize-package field-name val)
   "")
-- 
2.31.1