diff options
| -rw-r--r-- | gnu/services.scm | 93 | ||||
| -rw-r--r-- | tests/services.scm | 37 |
2 files changed, 80 insertions, 50 deletions
diff --git a/gnu/services.scm b/gnu/services.scm index a990d297c9..5410d31971 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -51,6 +51,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:autoload (ice-9 pretty-print) (pretty-print) @@ -297,35 +298,65 @@ singleton service type NAME, of which the returned service is an instance." (description "This is a simple service.")))) (service type value))) -(define (%delete-service kind services) - (let loop ((found #f) - (return '()) - (services services)) +(define-syntax clause-alist + (syntax-rules (=> delete) + "Build an alist of clauses. Each element has the form (KIND PROC LOC) +where PROC is the service transformation procedure to apply for KIND, and LOC +is the source location information." + ((_ (delete kind) rest ...) + (cons (list kind + (lambda (service) + #f) + (current-source-location)) + (clause-alist rest ...))) + ((_ (kind param => exp ...) rest ...) + (cons (list kind + (lambda (svc) + (let ((param (service-value svc))) + (service (service-kind svc) + (begin exp ...)))) + (current-source-location)) + (clause-alist rest ...))) + ((_) + '()))) + +(define (apply-clauses clauses services) + "Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICES, a list +of services. Use each clause at most once; raise an error if a clause was not +used." + (let loop ((services services) + (clauses clauses) + (result '())) (match services - ('() - (if found - (values return found) - (raise (formatted-message + (() + (match clauses + (() ;all clauses fired, good + (reverse result)) + (((kind _ properties) _ ...) ;one or more clauses didn't match + (raise (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (formatted-message (G_ "modify-services: service '~a' not found in service list") - (service-type-name kind))))) - ((service . rest) - (if (eq? (service-kind service) kind) - (loop service return rest) - (loop found (cons service return) rest)))))) - -(define-syntax %apply-clauses - (syntax-rules (=> delete) - ((_ ((delete kind) . rest) services) - (%apply-clauses rest (%delete-service kind services))) - ((_ ((kind param => exp ...) . rest) services) - (call-with-values (lambda () (%delete-service kind services)) - (lambda (svcs found) - (let ((param (service-value found))) - (cons (service (service-kind found) - (begin exp ...)) - (%apply-clauses rest svcs)))))) - ((_ () services) - services))) + (service-type-name kind))))))) + ((head . tail) + (let ((service clauses + (fold2 (lambda (clause service remainder) + (match clause + ((kind proc properties) + (if (eq? kind (service-kind service)) + (values (proc service) remainder) + (values service + (cons clause remainder)))))) + head + '() + clauses))) + (loop tail + (reverse clauses) + (if service + (cons service result) + result))))))) (define-syntax modify-services (syntax-rules () @@ -358,11 +389,9 @@ Consider this example: It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the -UDEV-SERVICE-TYPE. - -This is a shorthand for (filter-map (lambda (svc) ...) %base-services)." - ((_ services . clauses) - (%apply-clauses clauses services)))) +UDEV-SERVICE-TYPE." + ((_ services clauses ...) + (apply-clauses (clause-alist clauses ...) services)))) ;;; diff --git a/tests/services.scm b/tests/services.scm index 8cdb1b2a31..20ff4d317e 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015-2019, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2019, 2022, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -287,7 +287,7 @@ (x x)))) (test-equal "modify-services: do nothing" - '(1 2 3) + '(1 2 3) ;note: service order must be preserved (let* ((t1 (service-type (name 't1) (extensions '()) (description ""))) @@ -298,12 +298,11 @@ (extensions '()) (description ""))) (services (list (service t1 1) (service t2 2) (service t3 3)))) - (sort (map service-value - (modify-services services)) - <))) + (map service-value + (modify-services services)))) (test-equal "modify-services: delete service" - '(1) + '(1 4) ;note: service order must be preserved (let* ((t1 (service-type (name 't1) (extensions '()) (description ""))) @@ -313,12 +312,15 @@ (t3 (service-type (name 't3) (extensions '()) (description ""))) - (services (list (service t1 1) (service t2 2) (service t3 3)))) - (sort (map service-value - (modify-services services - (delete t3) - (delete t2))) - <))) + (t4 (service-type (name 't4) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) + (service t3 3) (service t4 4)))) + (map service-value + (modify-services services + (delete t3) + (delete t2))))) (test-error "modify-services: delete non-existing service" #t @@ -336,7 +338,7 @@ (delete t3)))) (test-equal "modify-services: change value" - '(2 11 33) + '(11 2 33) ;note: service order must be preserved (let* ((t1 (service-type (name 't1) (extensions '()) (description ""))) @@ -347,11 +349,10 @@ (extensions '()) (description ""))) (services (list (service t1 1) (service t2 2) (service t3 3)))) - (sort (map service-value - (modify-services services - (t1 value => 11) - (t3 value => 33))) - <))) + (map service-value + (modify-services services + (t1 value => 11) + (t3 value => 33))))) (test-error "modify-services: change value for non-existing service" #t |