bug#27155: [PATCH 1/2] DRAFT services: Extensions can specify a "finalization" procedure.

[Ludovic Courtès]

TODO: Add doc

* gnu/services.scm (<service-extension>)[finalize]: New field.
Rename 'service-extension' to '%service-extension'.
(right-identity): New procedure.
(service-extension): New macro.
(fold-services)[apply-finalization, compose*]: New procedures.
Honor finalizations.
* tests/services.scm ("fold-services with finalizations"): New test.
---
 gnu/services.scm   | 52 ++++++++++++++++++++++++++++++++++++++++++----------
 tests/services.scm | 34 ++++++++++++++++++++++++++++++++++
 2 files changed, 76 insertions(+), 10 deletions(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index 5c314748d..4ebce753b 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -119,10 +119,24 @@
 ;;; Code:
 
 (define-record-type <service-extension>
-  (service-extension target compute)
+  (%service-extension target compute finalize)
   service-extension?
-  (target  service-extension-target)              ;<service-type>
-  (compute service-extension-compute))            ;params -> params
+  (target   service-extension-target)              ;<service-type>
+  (compute  service-extension-compute)             ;value -> extension value
+  (finalize service-extension-finalize))           ;self other -> other
+
+(define (right-identity a b) b)
+
+(define-syntax service-extension
+  (syntax-rules ()
+    "Instantiate an extension of services of type TARGET.  COMPUTE takes the
+value of the source service and returns the extension value of the target.
+Optionally, FINALIZE takes the value of the source service and the final value
+of the target, and returns a new value for the target."
+    ((_ target compute)
+     (%service-extension target compute right-identity))
+    ((_ target compute finalize)
+     (%service-extension target compute finalize))))
 
 (define &no-default-value
   ;; Value used to denote service types that have no associated default value.
@@ -664,6 +678,21 @@ TARGET-TYPE; return the root service adjusted accordingly."
         (($ <service-extension> _ compute)
          (compute (service-value service))))))
 
+  (define (apply-finalization target)
+    (lambda (service)
+      (match (find (matching-extension target)
+                   (service-type-extensions (service-kind service)))
+        (($ <service-extension> _ _ finalize)
+         (lambda (final)
+           (finalize (service-value service) final))))))
+
+  (define (compose* procs)
+    (match procs
+      (()
+       identity)
+      (_
+       (apply compose procs))))
+
   (match (filter (lambda (service)
                    (eq? (service-kind service) target-type))
                  services)
@@ -671,15 +700,18 @@ TARGET-TYPE; return the root service adjusted 
accordingly."
      (let loop ((sink sink))
        (let* ((dependents (map loop (dependents sink)))
               (extensions (map (apply-extension sink) dependents))
+              ;; We distinguish COMPOSE and EXTEND because PARAMS typically
+              ;; has a different type than the elements of EXTENSIONS.
               (extend     (service-type-extend (service-kind sink)))
               (compose    (service-type-compose (service-kind sink)))
-              (params     (service-value sink)))
-         ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a
-         ;; different type than the elements of EXTENSIONS.
-         (if extend
-             (service (service-kind sink)
-                      (extend params (compose extensions)))
-             sink))))
+              (value      (if extend
+                              (extend (service-value sink)
+                                      (compose extensions))
+                              (service-value sink)))
+              (kind       (service-kind sink))
+              (finalizations (map (apply-finalization sink)
+                                  dependents)))
+         (service kind ((compose* finalizations) value)))))
     (()
      (raise
       (condition (&missing-target-service-error
diff --git a/tests/services.scm b/tests/services.scm
index 8484ee982..bb42e352a 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -88,6 +88,40 @@
     (and (eq? (service-kind r) t1)
          (service-value r))))
 
+(test-equal "fold-services with finalizations"
+  '(final 600 (initial-value 5 4 3 2 1 xyz 600))
+
+  ;; Similar to the one above, but this time with "finalization" extensions
+  ;; that modify the final result of compose/extend.
+  (let* ((t1 (service-type (name 't1) (extensions '())
+                           (compose concatenate)
+                           (extend cons)))
+         (t2 (service-type (name 't2)
+                           (extensions
+                            (list (service-extension t1
+                                                     (cut list 'xyz <>)
+                                                     (lambda (t2 t1)
+                                                       `(final ,t2 ,t1)))))
+                           (compose (cut reduce + 0 <>))
+                           (extend *)))
+         (t3 (service-type (name 't3)
+                           (extensions
+                            (list (service-extension t2 identity)
+                                  (service-extension t1 list)))))
+         (t4 (service-type (name 't4)
+                           (extensions
+                            (list (service-extension t2 (const 0)
+                                                     *)))))
+         (r  (fold-services (cons* (service t1 'initial-value)
+                                   (service t2 4)
+                                   (service t4 10)
+                                   (map (lambda (x)
+                                          (service t3 x))
+                                        (iota 5 1)))
+                            #:target-type t1)))
+    (and (eq? (service-kind r) t1)
+         (service-value r))))
+
 (test-assert "fold-services, ambiguity"
   (let* ((t1 (service-type (name 't1) (extensions '())
                            (compose concatenate)
-- 
2.13.0