05/06: services: Add 'lookup-service-types'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 49483f71381ad32cdbe81b1c8ed2cc023329cc18
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 8 13:26:08 2017 +0100

    services: Add 'lookup-service-types'.
    
    * gnu/services.scm (lookup-service-types): New procedure.
    * tests/services.scm ("lookup-service-types"): New test.
---
 gnu/services.scm   | 11 +++++++++++
 tests/services.scm | 10 +++++++++-
 2 files changed, 20 insertions(+), 1 deletion(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index df1bede..016ff08 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -55,6 +55,7 @@
 
             %service-type-path
             fold-service-types
+            lookup-service-types
 
             service
             service?
@@ -192,6 +193,16 @@ is used as the initial value of RESULT."
                                 seed
                                 modules))
 
+(define lookup-service-types
+  (let ((table
+         (delay (fold-service-types (lambda (type result)
+                                      (vhash-consq (service-type-name type)
+                                                   type result))
+                                    vlist-null))))
+    (lambda (name)
+      "Return the list of services with the given NAME (a symbol)."
+      (vhash-foldq* cons '() name (force table)))))
+
 ;; Services of a given type.
 (define-record-type <service>
   (make-service type value)
diff --git a/tests/services.scm b/tests/services.scm
index 8484ee9..ca32b56 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -23,7 +23,8 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-64))
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 match))
 
 (define live-service
   (@@ (gnu services herd) live-service))
@@ -206,4 +207,11 @@
       (list (map live-service-provision unload)
             (map shepherd-service-provision load)))))
 
+(test-eq "lookup-service-types"
+  system-service-type
+  (and (null? (lookup-service-types 'does-not-exist-at-all))
+       (match (lookup-service-types 'system)
+         ((one) one)
+         (x x))))
+
 (test-end)