From a5d78eb64bcb87440a0b3ff25eec5568df0bc47c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 31 Aug 2016 12:38:38 +0200
Subject: services: shepherd: Add 'shepherd-service-lookup-procedure'.

* gnu/services/shepherd.scm (shepherd-service-lookup-procedure): New
procedure.
(shepherd-service-back-edges)[provision->service]: Use it.
* tests/services.scm ("shepherd-service-lookup-procedure"): New test.
---
 gnu/services/shepherd.scm | 30 ++++++++++++++++++++----------
 tests/services.scm        | 11 ++++++++++-
 2 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index a14f51592a..3cfca8574e 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -52,6 +52,7 @@
 
             shepherd-service-file
 
+            shepherd-service-lookup-procedure
             shepherd-service-back-edges))
 
 ;;; Commentary:
@@ -249,20 +250,29 @@ stored."
 
     (gexp->file "shepherd.conf" config)))
 
+(define* (shepherd-service-lookup-procedure services
+                                            #:optional
+                                            (provision
+                                             shepherd-service-provision))
+  "Return a procedure that, when passed a symbol, return the item among
+SERVICES that provides this symbol.  PROVISION must be a one-argument
+procedure that takes a service and returns the list of symbols it provides."
+  (let ((services (fold (lambda (service result)
+                          (fold (cut vhash-consq <> service <>)
+                                result
+                                (provision service)))
+                        vlist-null
+                        services)))
+    (lambda (name)
+      (match (vhash-assq name services)
+        ((_ . service) service)
+        (#f            #f)))))
+
 (define (shepherd-service-back-edges services)
   "Return a procedure that, when given a <shepherd-service> from SERVICES,
 returns the list of <shepherd-service> that depend on it."
   (define provision->service
-    (let ((services (fold (lambda (service result)
-                            (fold (cut vhash-consq <> service <>)
-                                  result
-                                  (shepherd-service-provision service)))
-                          vlist-null
-                          services)))
-      (lambda (name)
-        (match (vhash-assq name services)
-          ((_ . service) service)
-          (#f            #f)))))
+    (shepherd-service-lookup-procedure services))
 
   (define edges
     (fold (lambda (service edges)
diff --git a/tests/services.scm b/tests/services.scm
index 477a197160..12745c8006 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -105,6 +105,15 @@
       (fold-services (list s) #:target-type t1)
       #f)))
 
+(test-assert "shepherd-service-lookup-procedure"
+  (let* ((s1 (shepherd-service (provision '(s1 s1b)) (start #f)))
+         (s2 (shepherd-service (provision '(s2 s2b)) (start #f)))
+         (s3 (shepherd-service (provision '(s3 s3b s3c)) (start #f)))
+         (lookup (shepherd-service-lookup-procedure (list s1 s2 s3))))
+    (and (eq? (lookup 's1) (lookup 's1b) s1)
+         (eq? (lookup 's2) (lookup 's2b) s2)
+         (eq? (lookup 's3) (lookup 's3b) s3))))
+
 (test-assert "shepherd-service-back-edges"
   (let* ((s1 (shepherd-service (provision '(s1)) (start #f)))
          (s2 (shepherd-service (provision '(s2))
-- 
cgit 1.4.1