08/10: services: Add 'dmd-service-back-edges'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 80a67734834a0981ca65cf1757a7d8408d02f1fd
Author: Ludovic Courtès <address@hidden>
Date:   Wed Oct 14 18:40:33 2015 +0200

    services: Add 'dmd-service-back-edges'.
    
    * gnu/services/dmd.scm (dmd-service-back-edges): New procedure.
    * tests/services.scm ("dmd-service-back-edges"): New test.
---
 gnu/services/dmd.scm |   34 +++++++++++++++++++++++++++++++++-
 tests/services.scm   |   10 ++++++++++
 2 files changed, 43 insertions(+), 1 deletions(-)

diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 7b6434a..e87b9e4 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -27,7 +27,9 @@
   #:use-module (gnu services)
   #:use-module (gnu packages admin)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (dmd-root-service-type
@@ -42,7 +44,9 @@
             dmd-service-respawn?
             dmd-service-start
             dmd-service-stop
-            dmd-service-auto-start?))
+            dmd-service-auto-start?
+
+            dmd-service-back-edges))
 
 ;;; Commentary:
 ;;;
@@ -179,4 +183,32 @@ failure."
 
     (gexp->file "dmd.conf" config)))
 
+(define (dmd-service-back-edges services)
+  "Return a procedure that, when given a <dmd-service> from SERVICES, returns
+the list of <dmd-service> that depend on it."
+  (define provision->service
+    (let ((services (fold (lambda (service result)
+                            (fold (cut vhash-consq <> service <>)
+                                  result
+                                  (dmd-service-provision service)))
+                          vlist-null
+                          services)))
+      (lambda (name)
+        (match (vhash-assq name services)
+          ((_ . service) service)
+          (#f            #f)))))
+
+  (define edges
+    (fold (lambda (service edges)
+            (fold (lambda (requirement edges)
+                    (vhash-consq (provision->service requirement) service
+                                 edges))
+                  edges
+                  (dmd-service-requirement service)))
+          vlist-null
+          services))
+
+  (lambda (service)
+    (vhash-foldq* cons '() service edges)))
+
 ;;; dmd.scm ends here
diff --git a/tests/services.scm b/tests/services.scm
index ae2d999..7d2e31b 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -18,6 +18,7 @@
 
 (define-module (test-services)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -104,6 +105,15 @@
       (fold-services (list s) #:target-type t1)
       #f)))
 
+(test-assert "dmd-service-back-edges"
+  (let* ((s1 (dmd-service (provision '(s1)) (start #f)))
+         (s2 (dmd-service (provision '(s2)) (requirement '(s1)) (start #f)))
+         (s3 (dmd-service (provision '(s3)) (requirement '(s1 s2)) (start #f)))
+         (e  (dmd-service-back-edges (list s1 s2 s3))))
+    (and (lset= eq? (e s1) (list s2 s3))
+         (lset= eq? (e s2) (list s3))
+         (null? (e s3)))))
+
 (test-end)