[shepherd] 08/08: support: Add 'let-loop' and use it in 'service-controller'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 01db6552f9f70c4a5fff32831c04d75313fb57a4
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 18 23:29:29 2023 +0100

    support: Add 'let-loop' and use it in 'service-controller'.
    
    * modules/shepherd/support.scm (let-loop): New macro.
    * modules/shepherd/service.scm (service-controller): Use it.
    * .dir-locals.el (scheme-mode): Add 'let-loop'.
---
 .dir-locals.el               |  1 +
 modules/shepherd/service.scm | 87 +++++++++++++++++++++-----------------------
 modules/shepherd/support.scm | 38 +++++++++++++++++++
 3 files changed, 80 insertions(+), 46 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index d4cfc6b..1794531 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -11,6 +11,7 @@
       . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")))
  (scheme-mode
   . ((indent-tabs-mode . nil)
+     (eval . (put 'let-loop 'scheme-indent-function 2))
      (eval . (put 'with-blocked-signals 'scheme-indent-function 1))
      (eval . (put 'with-process-monitor 'scheme-indent-function 0))
      (eval . (put 'with-service-registry 'scheme-indent-function 0))))
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index db46de8..c5b1899 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -306,30 +306,30 @@ Log abnormal termination reported by @var{status}."
   (define *service-stopped* (list 'service 'stopped!))
   (define (stopped-message? obj) (eq? *service-stopped* obj))
 
-  (let loop ((status 'stopped)
-             (value #f)
-             (condition #f)
-             (enabled? #t)
-             (respawns '())
-             (replacement #f))
+  (let-loop loop ((status 'stopped)
+                  (value #f)
+                  (condition #f)
+                  (enabled? #t)
+                  (respawns '())
+                  (replacement #f))
     (match (get-message channel)
       (('running reply)
        (put-message reply value)
-       (loop status value condition enabled? respawns replacement))
+       (loop))
       (('status reply)
        (put-message reply status)
-       (loop status value condition enabled? respawns replacement))
+       (loop))
       (('enabled? reply)
        (put-message reply enabled?)
-       (loop status value condition enabled? respawns replacement))
+       (loop))
       (('respawn-times reply)
        (put-message reply respawns)
-       (loop status value condition enabled? respawns replacement))
+       (loop))
 
       ('enable                                    ;no reply
-       (loop status value condition #t respawns replacement))
+       (loop (enabled? #t)))
       ('disable                                   ;no reply
-       (loop status value condition #f respawns replacement))
+       (loop (enabled? #f)))
 
       (('start reply)
        ;; Attempt to start SERVICE, blocking if it is already being started.
@@ -339,7 +339,7 @@ Log abnormal termination reported by @var{status}."
        (cond ((eq? 'running status)
               ;; SERVICE is already running: send #f on REPLY.
               (put-message reply #f)
-              (loop status value condition enabled? respawns replacement))
+              (loop))
              ((eq? 'starting status)
               ;; SERVICE is being started: wait until it has started and
               ;; then send #f on REPLY.
@@ -347,11 +347,10 @@ Log abnormal termination reported by @var{status}."
                (lambda ()
                  (wait condition)
                  (put-message reply #f)))
-              (loop status value condition enabled? respawns replacement))
+              (loop))
              (else
               ;; Become the one that starts SERVICE.
-              (let ((condition (make-condition))
-                    (notification (make-channel)))
+              (let ((notification (make-channel)))
                 (spawn-fiber
                  (lambda ()
                    (let ((running (get-message notification)))
@@ -365,20 +364,18 @@ Log abnormal termination reported by @var{status}."
                 (local-output (l10n "Starting service ~a...")
                               (canonical-name service))
                 (put-message reply notification)
-                (loop 'starting value condition enabled? respawns 
replacement)))))
-      (((? started-message?) value)               ;no reply
-       (when value
+                (loop (status 'starting)
+                      (condition (make-condition)))))))
+      (((? started-message?) new-value)           ;no reply
+       (when new-value
          (local-output (l10n "Service ~a running with value ~s.")
-                       (canonical-name service) value))
+                       (canonical-name service) new-value))
        (signal-condition! condition)
-       (loop (if (and value (not (one-shot? service)))
-                 'running
-                 'stopped)
-             (and (not (one-shot? service)) value)
-             #f
-             enabled?
-             respawns
-             replacement))
+       (loop (status (if (and new-value (not (one-shot? service)))
+                         'running
+                         'stopped))
+             (value (and (not (one-shot? service)) new-value))
+             (condition #f)))
 
       (('stop reply)
        ;; Attempt to stop SERVICE, blocking if it is already being stopped.
@@ -392,15 +389,14 @@ Log abnormal termination reported by @var{status}."
                (lambda ()
                  (wait condition)
                  (put-message reply #f)))
-              (loop status value condition enabled? respawns replacement))
+              (loop))
              ((not (eq? status 'running))
               ;; SERVICE is not running: send #f on REPLY.
               (put-message reply #f)
-              (loop status value condition enabled? respawns replacement))
+              (loop))
              (else
               ;; Become the one that stops SERVICE.
-              (let ((condition (make-condition))
-                    (notification (make-channel)))
+              (let ((notification (make-channel)))
                 (spawn-fiber
                  (lambda ()
                    (let ((stopped? (get-message notification)))
@@ -418,22 +414,23 @@ Log abnormal termination reported by @var{status}."
                 (local-output (l10n "Stopping service ~a...")
                               (canonical-name service))
                 (put-message reply notification)
-                (loop 'stopping value condition enabled?
-                      respawns replacement)))))
+                (loop (status 'stopping)
+                      (condition (make-condition)))))))
       ((? stopped-message?)                       ;no reply
        (local-output (l10n "Service ~a is now stopped.")
                      (canonical-name service))
        (signal-condition! condition)
-       (loop 'stopped #f #f enabled? '() replacement))
+       (loop (status 'stopped) (value #f) (condition #f)
+             (respawns '())))
 
       ('notify-termination                        ;no reply
-       (loop 'stopped #f condition enabled? respawns replacement))
+       (loop (status 'stopped) (value #f)))
 
       (('handle-termination exit-status)          ;no reply
        ;; Handle premature termination of this service's process, possibly by
        ;; respawning it, unless STATUS is 'stopping'.
        (if (eq? status 'stopping)
-           (loop status value condition enabled? respawns replacement)
+           (loop)
            (begin
              (spawn-fiber
               (lambda ()
@@ -441,26 +438,24 @@ Log abnormal termination reported by @var{status}."
                  ((slot-ref service 'handle-termination)
                   service value exit-status))
                 (put-message channel 'notify-termination)))
-             (loop 'stopped #f #f enabled? respawns replacement))))
+             (loop (status 'stopped) (value #f) (condition #f)))))
 
       ('record-respawn-time                       ;no reply
-       (loop status value condition enabled?
-             (cons (current-time) respawns)
-             replacement))
+       (loop (respawns (cons (current-time) respawns))))
 
-      (('replace-if-running replacement reply)
+      (('replace-if-running new-service reply)
        (if (eq? status 'running)
            (begin
              (local-output (l10n "Recording replacement for ~a.")
                            (canonical-name service))
              (put-message reply #t)
-             (loop status value condition enabled? respawns replacement))
+             (loop (replacement new-service)))
            (begin
              (put-message reply #f)
-             (loop status value condition enabled? respawns #f))))
+             (loop (replacement #f)))))
       (('replacement reply)
        (put-message reply replacement)
-       (loop status value condition enabled? respawns replacement))
+       (loop))
 
       ('terminate                                 ;no reply
        (if (eq? status 'stopped)
@@ -473,7 +468,7 @@ Log abnormal termination reported by @var{status}."
              (local-output
               (l10n "Attempt to terminate controller of ~a in ~a state!")
               (canonical-name service) status)
-             (loop status value condition enabled? respawns replacement)))))))
+             (loop)))))))
 
 (define (service? obj)
   "Return true if OBJ is a service."
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index eaf215d..96c1c70 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -26,6 +26,7 @@
   #:use-module (ice-9 format)
   #:export (caught-error
             assert
+            let-loop
 
             buffering
             catch-system-error
@@ -84,6 +85,43 @@
         (local-output (l10n "Assertion ~a failed.") 'EXPR)
         (throw 'assertion-failed))))
 
+(define-syntax-rule (let-loop loop ((variable value) ...)
+                              body ...)
+  "Similar to a named let, define @var{loop} as a procedure that takes the 
given
+@var{variable}s and their initial @var{value}s.  The main difference is that
+@var{loop} is in fact a macro that can be passed a subset of @var{variable}s.
+The example below illustrates that:
+
+@example
+(let-loop loop ((x 1) (y 2) (z 3))
+  (match (get-message channel)
+    ('print-x
+     (display x)
+     (loop))                ;x, y, and z unchanged
+    (('set-y value)
+     (loop (y value)))))    ;only y gets a new value
+@end example
+
+That reduces the amount of boilerplate for loops with many variables."
+  (let real-loop ((variable value) ...)
+    (define-syntax extract-value
+      (syntax-rules (variable ...)
+        ;; Extract the value of the variable given as its first argument among
+        ;; the given arguments.
+        ((_ variable ((variable x) rest (... ...)))
+         x)
+        ...
+        ((_ binding ((_ _) rest (... ...)))
+         (extract-value binding (rest (... ...))))
+        ((_ binding ())
+         binding)))
+    (letrec-syntax ((loop (syntax-rules (variable ...)
+                            ((_ args (... ...))
+                             (real-loop
+                              (extract-value variable (args (... ...)))
+                              ...)))))
+      body ...)))
+
 (define (buffering port type . args)
   "Return PORT after changing its buffering to TYPE and ARGS."
   (apply setvbuf port type args)