From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:40446) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dFpHE-0002tG-07 for guix-patches@gnu.org; Tue, 30 May 2017 18:06:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dFpH8-0001jH-Nw for guix-patches@gnu.org; Tue, 30 May 2017 18:06:07 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:43218) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dFpH8-0001j6-K4 for guix-patches@gnu.org; Tue, 30 May 2017 18:06:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dFpH8-0002CM-DB for guix-patches@gnu.org; Tue, 30 May 2017 18:06:02 -0400 Subject: bug#27155: [PATCH 1/2] DRAFT services: Extensions can specify a "finalization" procedure. References: <20170530215850.7522-1-ludo@gnu.org> In-Reply-To: <20170530215850.7522-1-ludo@gnu.org> Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Wed, 31 May 2017 00:05:08 +0200 Message-Id: <20170530220509.8254-1-ludo@gnu.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 27155@debbugs.gnu.org Cc: Alex Kost TODO: Add doc * gnu/services.scm ()[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 target compute) + (%service-extension target compute finalize) service-extension? - (target service-extension-target) ; - (compute service-extension-compute)) ;params -> params + (target service-extension-target) ; + (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." (($ _ compute) (compute (service-value service)))))) + (define (apply-finalization target) + (lambda (service) + (match (find (matching-extension target) + (service-type-extensions (service-kind service))) + (($ _ _ 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