[shepherd] 01/06: timer: #:days-of-week is now a symbol.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit 2e844430ec8aa4aebb7a8c185f54d6f91bbc3cfe
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed May 8 15:46:15 2024 +0200

    timer: #:days-of-week is now a symbol.
    
    That avoids a situation where users have to wonder whether 0 is Sunday
    or Monday and is overall more convenient.
    
    Suggested by Felix Lechner <felix.lechner@lease-up.com>.
    
    * modules/shepherd/service/timer.scm (define-weekday-symbolic-mapping):
    New macro.
    (weekday-symbol->index, weekday-index->symbol): New procedures.
    (any-day-of-week): Change to a list of symbols.
    (validate-days-of-week): New procedure.
    (calendar-event): Use it to validate #:days-of-week.  Convert #:days-of-week
    to indexes.
    (cron-string->calendar-event): For weekdays, pass NUMBERS through
    ‘weekday-index->symbol’.
    * tests/services/timer-events.scm ("next-calendar-event, days of week")
    (test-cron): Adjust #:days-of-week values accordingly.
    * doc/shepherd.texi (Timers): Adjust accordingly.
---
 doc/shepherd.texi                  |  6 +++-
 modules/shepherd/service/timer.scm | 58 +++++++++++++++++++++++++++++++++++---
 tests/services/timer-events.scm    | 13 +++++----
 3 files changed, 67 insertions(+), 10 deletions(-)

diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 2b89856..ea5e60f 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1444,7 +1444,7 @@ hours, minutes, and so on.  Here are a few examples:
 @lisp
 ;; Every Sunday and every Wednesday, at noon.
 (calendar-event #:hours '(12) #:minutes '(0)
-                #:days-of-week '(0 3))
+                #:days-of-week '(sunday wednesday))
 
 ;; Everyday at 11AM and 8PM.
 (calendar-event #:hours '(11 20) #:minutes '(0))
@@ -1460,6 +1460,10 @@ hours, minutes, and so on.  Here are a few examples:
   [#:seconds '(0)]
 Return a calendar event that obeys the given constraints.  Raise an
 error if one of the values is out of range.
+
+All the arguments are lists of integers as commonly used in the
+Gregorian calendar, except for @code{days-of-week} which is a list of
+symbols denoting weekdays: @code{'monday}, @code{'tuesday}, etc.
 @end deffn
 
 @cindex Vixie cron, converting date specifications
diff --git a/modules/shepherd/service/timer.scm 
b/modules/shepherd/service/timer.scm
index 5fe6d3e..f978002 100644
--- a/modules/shepherd/service/timer.scm
+++ b/modules/shepherd/service/timer.scm
@@ -30,6 +30,7 @@
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:export (calendar-event
             calendar-event?
             calendar-event-months
@@ -76,10 +77,44 @@
   (months        calendar-event-months)
   (days-of-week  calendar-event-days-of-week))
 
+(define-syntax define-weekday-symbolic-mapping
+  (syntax-rules ()
+    "Define @var{symbol->index} as a procedure that maps symbolic weekday
+names to indexes, and @var{index->symbol} that does the opposite."
+    ((_ symbol->index index->symbol (names ...))
+     (begin
+       (define symbol->index
+         (let ((mapping (let loop ((lst '(names ...))
+                                   (index 0)
+                                   (result vlist-null))
+                          (match lst
+                            (()
+                             result)
+                            ((head . tail)
+                             (loop tail
+                                   (+ 1 index)
+                                   (vhash-consq head index result)))))))
+           (lambda (symbol)
+             "Given @var{symbol}, a weekday, return its index or #f."
+             (match (vhash-assq symbol mapping)
+               (#f #f)
+               ((_ . index) index)))))
+
+       (define index->symbol
+         (let ((mapping (vector 'names ...)))
+           (lambda (index)
+             "Given @var{index}, return the corresponding weekday symbol or 
#f."
+             (and (>= index 0) (< index (vector-length mapping))
+                  (vector-ref mapping index)))))))))
+
+(define-weekday-symbolic-mapping
+  weekday-symbol->index weekday-index->symbol
+  (sunday monday tuesday wednesday thursday friday saturday))
+
 (define any-minute (iota 60))
 (define any-hour (iota 24))
 (define any-day-of-month (iota 31 1))
-(define any-day-of-week (iota 7))
+(define any-day-of-week (map weekday-index->symbol (iota 7)))
 (define any-month (iota 12 1))
 
 (define-syntax validate-range
@@ -94,6 +129,16 @@
                                              'lst value min max)))))))
                lst))))
 
+(define (validate-days-of-week days-of-week)
+  (for-each (lambda (value)
+              (unless (memq value any-day-of-week)
+                (raise (condition
+                        (&message
+                         (message (format #f (l10n "calendar-event: ~a: \
+invalid day of week")
+                                          value)))))))
+            days-of-week))
+
 (define* (calendar-event #:key
                          (seconds '(0))
                          (minutes any-minute)
@@ -105,10 +150,12 @@
   (validate-range seconds       0 - 59)
   (validate-range minutes       0 - 59)
   (validate-range hours         0 - 23)
-  (validate-range days-of-week  0 - 6)
   (validate-range days-of-month 1 - 31)
   (validate-range months        1 - 12)
-  (%calendar-event seconds minutes hours days-of-month months days-of-week))
+  (validate-days-of-week days-of-week)
+
+  (%calendar-event seconds minutes hours days-of-month months
+                   (map weekday-symbol->index days-of-week)))
 
 (define-syntax-rule (define-date-setter name getter)
   (define (name date value)
@@ -358,7 +405,10 @@ five minutes after midnight, every day;
       (str (match (string-tokenize str not-comma)
              (((= range->numbers numbers) ...)
               (and (every list? numbers)
-                   (concatenate numbers)))
+                   (let ((numbers (concatenate numbers)))
+                     (if (= 7 count)
+                         (map weekday-index->symbol numbers)
+                         numbers))))
              (_ #f)))))
 
   (define (fail component)
diff --git a/tests/services/timer-events.scm b/tests/services/timer-events.scm
index d85f528..f74bf5c 100644
--- a/tests/services/timer-events.scm
+++ b/tests/services/timer-events.scm
@@ -64,8 +64,7 @@
   ;; 31
   (let ((event (calendar-event #:hours '(6 12 18)
                                #:minutes '(30)
-                               ;; Sunday, Wednesday, Saturday
-                               #:days-of-week '(0 3 6))))
+                               #:days-of-week '(sunday wednesday saturday))))
     (let loop ((date (make-date 123456789 42 09 12
                                 ;; Start on Saturday, March 2nd.
                                 02 03 2024 3600))
@@ -110,7 +109,7 @@
              (calendar-event #:minutes '(30)
                              #:hours '(4)
                              #:days-of-month '(1 15)
-                             #:days-of-week '(5)))
+                             #:days-of-week '(friday)))
 
   ;; five minutes after midnight, every day
   (test-cron "5 0 * * *"
@@ -125,7 +124,11 @@
   (test-cron "0 22 * * 1-5"
              (calendar-event #:minutes '(0)
                              #:hours '(22)
-                             #:days-of-week '(1 2 3 4 5)))
+                             #:days-of-week '(monday
+                                              tuesday
+                                              wednesday
+                                              thursday
+                                              friday)))
 
   ;; 23 minutes after midnight, 2am, 4am ..., everyday
   (test-cron "23 0-23/2 * * *"
@@ -136,7 +139,7 @@
   (test-cron "5 4 * * 0"
              (calendar-event #:minutes '(5)
                              #:hours '(4)
-                             #:days-of-week '(0))))
+                             #:days-of-week '(sunday))))
 
 (let-syntax ((test-cron-error
               (syntax-rules ()