03/05: services: Service types can now specify a default value for instances.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1bb895eabf74a1e571887eb1521915e668a5c28d
Author: Ludovic Courtès <address@hidden>
Date:   Sat Apr 15 23:53:23 2017 +0200

    services: Service types can now specify a default value for instances.
    
    * gnu/services.scm (&no-default-value): New variable.
    (<service-type>)[default-value]: New field.
    (<service>): Rename constructor from 'service' to 'make-service'.
    (service): New macro.
    (%service-with-default-value): New procedure.
    (&missing-value-service-error): New error condition.
    * tests/services.scm ("services, default value"): New test.
    * doc/guix.texi (Service Types and Services): Document 'default-value'.
    (Service Reference): Explain default values.
---
 doc/guix.texi      | 39 ++++++++++++++++++++++++++++++----
 gnu/services.scm   | 62 +++++++++++++++++++++++++++++++++++++++++++++++++-----
 tests/services.scm | 11 ++++++++++
 3 files changed, 103 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index bf46f89..fdd7114 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -15555,11 +15555,12 @@ with a simple example, the service type for the Guix 
build daemon
    (extensions
     (list (service-extension shepherd-root-service-type guix-shepherd-service)
           (service-extension account-service-type guix-accounts)
-          (service-extension activation-service-type guix-activation)))))
+          (service-extension activation-service-type guix-activation)))
+   (default-value (guix-configuration))))
 @end example
 
 @noindent
-It defines two things:
+It defines three things:
 
 @enumerate
 @item
@@ -15572,6 +15573,9 @@ service, returns a list of objects to extend the 
service of that type.
 
 Every service type has at least one service extension.  The only
 exception is the @dfn{boot service type}, which is the ultimate service.
+
address@hidden
+Optionally, a default value for instances of this type.
 @end enumerate
 
 In this example, @var{guix-service-type} extends three services:
@@ -15607,7 +15611,13 @@ A service of this type is instantiated like this:
 The second argument to the @code{service} form is a value representing
 the parameters of this specific service instance.
 @xref{guix-configuration-type, @code{guix-configuration}}, for
-information about the @code{guix-configuration} data type.
+information about the @code{guix-configuration} data type.  When the
+value is omitted, the default value specified by
address@hidden is used:
+
address@hidden
+(service guix-service-type)
address@hidden example
 
 @var{guix-service-type} is quite simple because it extends other
 services but is not extensible itself.
@@ -15670,10 +15680,31 @@ Services}).  This section provides a reference on how 
to manipulate
 services and service types.  This interface is provided by the
 @code{(gnu services)} module.
 
address@hidden {Scheme Procedure} service @var{type} @var{value}
address@hidden {Scheme Procedure} service @var{type} address@hidden
 Return a new service of @var{type}, a @code{<service-type>} object (see
 below.)  @var{value} can be any object; it represents the parameters of
 this particular service instance.
+
+When @var{value} is omitted, the default value specified by @var{type}
+is used; if @var{type} does not specify a default value, an error is
+raised.
+
+For instance, this:
+
address@hidden
+(service openssh-service-type)
address@hidden example
+
address@hidden
+is equivalent to this:
+
address@hidden
+(service openssh-service-type
+         (openssh-configuration))
address@hidden example
+
+In both cases the result is an instance of @code{openssh-service-type}
+with the default configuration.
 @end deffn
 
 @deffn {Scheme Procedure} service? @var{obj}
diff --git a/gnu/services.scm b/gnu/services.scm
index af4cffe..b1b53fd 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -25,6 +25,7 @@
   #:use-module (guix profiles)
   #:use-module (guix sets)
   #:use-module (guix ui)
+  #:use-module ((guix utils) #:select (source-properties->location))
   #:use-module (guix modules)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
@@ -47,6 +48,7 @@
             service-type-extensions
             service-type-compose
             service-type-extend
+            service-type-default-value
 
             service
             service?
@@ -60,6 +62,9 @@
             fold-services
 
             service-error?
+            missing-value-service-error?
+            missing-value-service-error-type
+            missing-value-service-error-location
             missing-target-service-error?
             missing-target-service-error-service
             missing-target-service-error-target-type
@@ -119,6 +124,10 @@
   (target  service-extension-target)              ;<service-type>
   (compute service-extension-compute))            ;params -> params
 
+(define &no-default-value
+  ;; Value used to denote service types that have no associated default value.
+  '(no default value))
+
 (define-record-type* <service-type> service-type make-service-type
   service-type?
   (name       service-type-name)                  ;symbol (for debugging)
@@ -132,7 +141,11 @@
 
   ;; Extend the services' own parameters with the extension composition.
   (extend     service-type-extend                 ;list of Any -> parameters
-              (default #f)))
+              (default #f))
+
+  ;; Optional default value for instances of this type.
+  (default-value service-type-default-value       ;Any
+                 (default &no-default-value)))
 
 (define (write-service-type type port)
   (format port "#<service-type ~a ~a>"
@@ -143,11 +156,53 @@
 
 ;; Services of a given type.
 (define-record-type <service>
-  (service type value)
+  (make-service type value)
   service?
   (type       service-kind)
   (value      service-value))
 
+(define-syntax service
+  (syntax-rules ()
+    "Return a service instance of TYPE.  The service value is VALUE or, if
+omitted, TYPE's default value."
+    ((_ type value)
+     (make-service type value))
+    ((_ type)
+     (%service-with-default-value (current-source-location)
+                                  type))))
+
+(define (%service-with-default-value location type)
+  "Return a instance of service type TYPE with its default value, if any.  If
+TYPE does not have a default value, an error is raised."
+  ;; TODO: Currently this is a run-time error but with a little bit macrology
+  ;; we could turn it into an expansion-time error.
+  (let ((default (service-type-default-value type)))
+    (if (eq? default &no-default-value)
+        (let ((location (source-properties->location location)))
+          (raise
+           (condition
+            (&missing-value-service-error (type type) (location location))
+            (&message
+             (message (format #f (_ "~a: no value specified \
+for service of type '~a'")
+                              (location->string location)
+                              (service-type-name type)))))))
+        (service type default))))
+
+(define-condition-type &service-error &error
+  service-error?)
+
+(define-condition-type &missing-value-service-error &service-error
+  missing-value-service-error?
+  (type     missing-value-service-error-type)
+  (location missing-value-service-error-location))
+
+
+
+;;;
+;;; Helpers.
+;;;
+
 (define service-parameters
   ;; Deprecated alias.
   service-value)
@@ -541,9 +596,6 @@ kernel."
 ;;; Service folding.
 ;;;
 
-(define-condition-type &service-error &error
-  service-error?)
-
 (define-condition-type &missing-target-service-error &service-error
   missing-target-service-error?
   (service      missing-target-service-error-service)
diff --git a/tests/services.scm b/tests/services.scm
index 7983427..8484ee9 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -31,6 +31,17 @@
 
 (test-begin "services")
 
+(test-equal "services, default value"
+  '(42 123 234 error)
+  (let* ((t1 (service-type (name 't1) (extensions '())))
+         (t2 (service-type (name 't2) (extensions '())
+                           (default-value 42))))
+    (list (service-value (service t2))
+          (service-value (service t2 123))
+          (service-value (service t1 234))
+          (guard (c ((missing-value-service-error? c) 'error))
+            (service t1)))))
+
 (test-assert "service-back-edges"
   (let* ((t1 (service-type (name 't1) (extensions '())
                            (compose +) (extend *)))