From 0ea510ce51dd2dded98315609df651be9493a497 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 23 Jun 2022 01:14:14 +0200 Subject: Rewrote extenders or limiter generations. The old macro was fancy, but rather unweildly. The new version looks really similar when looking, but without as much magic. --- module/vcomponent/recurrence/generate.scm | 152 ++++++++++++++---------------- 1 file changed, 70 insertions(+), 82 deletions(-) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 4dccecf1..a9ed0fe9 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -2,7 +2,6 @@ :use-module (hnh util) :use-module (hnh util exceptions) :use-module (srfi srfi-1) - :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) :use-module (srfi srfi-71) @@ -18,94 +17,83 @@ -;; a → b → (a . b) -(define ((con x) y) - (cons x y)) - -(eval-when (expand load compile eval) - (define (stx->bystx symbol str-transformer) - (->> symbol - symbol->string - str-transformer - (string-append (str-transformer "by")) - string->symbol)) - - (define (by-proc symbol) - (stx->bystx symbol string-downcase)) - - (define (by-symb symbol) - (stx->bystx symbol string-upcase)) - - (use-modules (ice-9 match)) - - (define (make-extender-or-limiter extender? rr cases) - `(case (freq ,rr) - ,@(map (match-lambda - [(key '|| cc ...) - `((,key) - (filter - identity - (list - ,@(map (label self - (match-lambda - [('unless pred field) - `(let ((yearday (,(by-proc 'yearday) ,rr)) - (monthday (,(by-proc 'monthday) ,rr)) - (weekno (,(by-proc 'weekno) ,rr)) - (month (,(by-proc 'month) ,rr)) - ) - (if ,pred #f - ,(self field)))] - [field - `(and=> (,(by-proc field) ,rr) - ,(if extender? - `(cut map (con (quote ,(by-symb field))) - <>) - `(con (quote ,(by-symb field)))))])) - cc))))]) - cases))) - - (define-macro (make-extenders rr . cases) - `(apply cross-product ,(make-extender-or-limiter #t rr cases))) - - (define-macro (make-limiters rr . cases) - (make-extender-or-limiter #f rr cases))) +;; Returns #t if any of the predicates return true when applied to object. +(define (any-predicate object predicates) + ((@ (srfi srfi-1) any) + (lambda (pred) (pred object)) + predicates)) + +;; NOTE these should be renamed +(define (all rrule . args) (filter-map (lambda (proc) (proc rrule)) args)) +(define (any rrule . args) (any-predicate rrule args)) + +;; Return #f or a procedure which conses @var{symbol} to each element returned +;; by @var{accessor} applied to @var{rrule}. +(define ((extender accessor symbol) rrule) + (and=> (accessor rrule) (lambda (v) (map (lambda (x) (cons symbol x)) v)))) + +;; Return #f or a procedure which conses @var{symbol} to the return of +;; @var{accessor} applied to @var{rrule}. +(define ((limiter accessor symbol) rrule) + (and=> (accessor rrule) (lambda (v) (cons symbol v)))) + ;; rrule → (list extension-rule) (define (all-extenders rrule) - (make-extenders - rrule - [YEARLY || month weekno yearday monthday - - ;; see Note 2, p. 44 - (unless (or yearday monthday - ;; weekno and month are still expanders. They however - ;; cause day to be omited here to prevent datetimes - ;; from being generated from both directions. - ;; They are instead handled under BYWEEKNO & BYMONTH - ;; respectively. - weekno month) day) - hour minute second] - [MONTHLY || monthday (unless monthday day) hour minute second] - [WEEKLY || day hour minute second] - [DAILY || hour minute second] - [HOURLY || minute second] - [MINUTELY || second] - [SECONDLY || #| null |#])) + (let ((second (extender bysecond 'BYSECOND)) + (minute (extender byminute 'BYMINUTE)) + (hour (extender byhour 'BYHOUR)) + (day (extender byday 'BYDAY)) + (monthday (extender bymonthday 'BYMONTHDAY)) + (yearday (extender byyearday 'BYYEARDAY)) + (weekno (extender byweekno 'BYWEEKNO)) + (month (extender bymonth 'BYMONTH)) + ;; (bysetpos bysetpos) + ) + (apply cross-product + (case (freq rrule) + ((YEARLY) (all rrule month weekno yearday monthday + ;; see Note 2, p. 44 + (if (any rrule yearday monthday + ;; weekno and month are still expanders. They however + ;; cause day to be omited here to prevent datetimes + ;; from being generated from both directions. + ;; They are instead handled under BYWEEKNO & BYMONTH + ;; respectively. + weekno month) + (const #f) + day) + hour minute second)) + ((MONTHLY) (all rrule monthday (if (monthday rrule) (const #f) day) hour minute second)) + ((WEEKLY) (all rrule day hour minute second)) + ((DAILY) (all rrule hour minute second)) + ((HOURLY) (all rrule minute second)) + ((MINUTELY) (all rrule second)) + ((SECONDLY) (all rrule #| null |#)) + )))) + (define (all-limiters rrule) - (make-limiters - rrule - [YEARLY || day #| setpos |#] - [MONTHLY || month day #|setpos|#] - [WEEKLY || month #|setpos|#] - [DAILY || month monthday day #|setpos|#] - [HOURLY || month yearday monthday day hour #|setpos|#] - [MINUTELY || month yearday monthday day hour minute #|setpos|#] - [SECONDLY || month yearday monthday day hour minute second #|setpos|#] - )) + (let ((second (limiter bysecond 'BYSECOND)) + (minute (limiter byminute 'BYMINUTE)) + (hour (limiter byhour 'BYHOUR)) + (day (limiter byday 'BYDAY)) + (monthday (limiter bymonthday 'BYMONTHDAY)) + (yearday (limiter byyearday 'BYYEARDAY)) + (weekno (limiter byweekno 'BYWEEKNO)) + (month (limiter bymonth 'BYMONTH)) + ;; (bysetpos bysetpos) + ) + (case (freq rrule) + ((YEARLY) (all rrule day #| setpos |#)) + ((MONTHLY) (all rrule month day #| setpos |#)) + ((WEEKLY) (all rrule month #| setpos |#)) + ((DAILY) (all rrule month monthday day #| setpos |#)) + ((HOURLY) (all rrule month yearday monthday day hour #| setpos |#)) + ((MINUTELY) (all rrule month yearday monthday day hour minute #| setpos |#)) + ((SECONDLY) (all rrule month yearday monthday day hour minute second #| setpos |#))))) ;; next, done ;; (a, a → values a), a, (list a) → values a -- cgit v1.2.3