#27155 [PATCH 0/2] Support service extensions on the "final" service values

Message #8 received at 27155@debbugs.gnu.org (full text, mbox, reply):

Received: (at 27155) by debbugs.gnu.org; 30 May 2017 22:05:43 +0000
From debbugs-submit-bounces@debbugs.gnu.org Tue May 30 18:05:43 2017
Received: from localhost ([127.0.0.1]:45893 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces@debbugs.gnu.org>)
	id 1dFpGo-0002Bi-W0
	for submit@debbugs.gnu.org; Tue, 30 May 2017 18:05:43 -0400
Received: from eggs.gnu.org ([208.118.235.92]:49163)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@gnu.org>) id 1dFpGn-0002BQ-GR
 for 27155@debbugs.gnu.org; Tue, 30 May 2017 18:05:41 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@gnu.org>) id 1dFpGh-0001bM-4t
 for 27155@debbugs.gnu.org; Tue, 30 May 2017 18:05:36 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:56338)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@gnu.org>)
 id 1dFpGZ-0001ah-OH; Tue, 30 May 2017 18:05:27 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:60370 helo=gnu.org)
 by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@gnu.org>)
 id 1dFpGY-0000ZU-UO; Tue, 30 May 2017 18:05:27 -0400
From: Ludovic Courtès <ludo@gnu.org>
To: 27155@debbugs.gnu.org
Subject: [PATCH 1/2] DRAFT services: Extensions can specify a "finalization"
 procedure.
Date: Wed, 31 May 2017 00:05:08 +0200
Message-Id: <20170530220509.8254-1-ludo@gnu.org>
X-Mailer: git-send-email 2.13.0
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
X-Debbugs-Envelope-To: 27155
Cc: Alex Kost <alezost@gmail.com>,
 Ludovic Courtès <ludo@gnu.org>
X-BeenThere: debbugs-submit@debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request@debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit@debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request@debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request@debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces@debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces@debbugs.gnu.org>
X-Spam-Score: -5.0 (-----)

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

Send a report that this bug log contains spam.