Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Tue, 30 May 2017 22:00:02 UTC
Severity: important
Tags: patch
View this message in rfc822 format
From: Ludovic Courtès <ludo <at> gnu.org> To: 27155 <at> debbugs.gnu.org Cc: Alex Kost <alezost <at> gmail.com>, Ludovic Courtès <ludo <at> gnu.org> Subject: bug#27155: [PATCH 1/2] DRAFT services: Extensions can specify a "finalization" procedure. Date: Wed, 31 May 2017 00:05:08 +0200
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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.