From 22f28015981295660ff98b43789f8c4c99134f36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 16 Oct 2023 19:39:12 +0200 Subject: Move timespec and recur-rule to new object system. --- module/vcomponent/formats/xcal/parse.scm | 2 +- module/vcomponent/recurrence.scm | 2 +- module/vcomponent/recurrence/internal.scm | 147 ++++++++++++++++-------------- module/vcomponent/recurrence/parse.scm | 130 +++++++++++--------------- 4 files changed, 133 insertions(+), 148 deletions(-) (limited to 'module/vcomponent') diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 5ae1b928..d108b11c 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -96,7 +96,7 @@ ;; freq until count interval wkst - (apply (@ (vcomponent recurrence internal) make-recur-rule) + (apply (@ (vcomponent recurrence internal) recur-rule) (concatenate (filter identity (for key in '(bysecond byminute byhour byday bymonthday diff --git a/module/vcomponent/recurrence.scm b/module/vcomponent/recurrence.scm index ffda0e7f..f7e82a1e 100644 --- a/module/vcomponent/recurrence.scm +++ b/module/vcomponent/recurrence.scm @@ -4,4 +4,4 @@ :use-module (vcomponent recurrence internal) :re-export (generate-recurrence-set parse-recurrence-rule - repeating? make-recur-rule)) + repeating? recur-rule)) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 9bf425ac..4b4cd336 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -4,20 +4,23 @@ :use-module (srfi srfi-88) ; better keywords :use-module ((vcomponent base) :select (prop)) :use-module (ice-9 i18n) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) :use-module (ice-9 format) + :use-module (ice-9 pretty-print) :use-module (hnh util) + :use-module (hnh util object) + :use-module ((hnh util type) :select (list-of pair-of false?)) :use-module (datetime) :replace (count) :export (repeating? - make-recur-rule + recur-rule freq until interval bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos wkst + freq-placeholder + recur-rule->rrule-string recur-rule->rrule-sxml @@ -28,8 +31,11 @@ (define weekdays (weekday-list sun)) +(define freq-placeholder (gensym)) + (define intervals - '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) + `(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY + ,freq-placeholder)) ;; EXDATE is also a property linked to recurense rules @@ -40,71 +46,74 @@ (prop ev 'RDATE) (prop ev '-X-HNH-ALTERNATIVES))) -;; weekday := [0, 7) - -;; Immutable, since I easily want to be able to generate the recurence set for -;; the same event multiple times. -(define-immutable-record-type - (make-recur-rule% freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst) - recur-rule? - (freq freq) ; 'SECONDLY | 'MINUTELY | 'HOURLY | 'DAILY | 'WEEKLY | 'MONTHLY | 'YEARLY - (until until) ; | - (count count) ; 𝐙₊ - (interval interval) ; 𝐙₊ - (bysecond bysecond) ; (list [0, 60]) - (byminute byminute) ; (list [0, 59]) - (byhour byhour) ; (list [0, 23]) - (byday byday) ; (list (cons [#f | 𝐙] weekday) - (bymonthday bymonthday) ; (list [-31, 31] \ { 0 }) - (byyearday byyearday) ; (list [-366, 366] \ { 0 }) - (byweekno byweekno) ; (list [-53, 53] \ { 0 }) - (bymonth bymonth) ; (list [-12, 12] \ { 0 }) - (bysetpos bysetpos) ; (list [-366, 366] \ { 0 }) - (wkst wkst) ; weekday - ) - - - -;; Interval and wkst have default values, since those are assumed -;; anyways, and having them set frees us from having to check them at -;; the use site. -(define* (make-recur-rule - key: - freq until count (interval 1) bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - (wkst monday)) - ;; TODO possibly validate fields here - ;; to prevent creation of invalid rules. - ;; This was made apparent when wkst was (incorrectly) set to MO, - ;; which later crashed generate-recurrence-set. - - ;; Allow `(cons #f day)' to be written as just `day'. - (let ((byday* (if byday - (map (lambda (day) - (if (number? day) - (cons #f day) - day)) - byday) - #f))) - (make-recur-rule% freq until count interval bysecond byminute byhour - byday* bymonthday byyearday byweekno bymonth bysetpos - wkst))) - -;; only print fields with actual values. -(set-record-type-printer! - - (lambda (r port) - (define (get f) - ((record-accessor f) r)) - (with-output-to-string - (lambda () - (display "#<" port) - (for field in (record-type-fields ) - (awhen (get field) - (format port " ~a=~a" field it))) - (display ">" port))))) +(define-syntax-rule (in-range? x start end) + (<= start x end)) + +(define (recur-rule-constructor-factory primitive-constructor type-checker) + ;; Interval and wkst have default values, since those are assumed + ;; anyways, and having them set frees us from having to check them at + ;; the use site. + (lambda* (key: freq until count (interval 1) bysecond byminute + byhour byday bymonthday byyearday byweekno bymonth + bysetpos (wkst monday)) + ;; Allow `(cons #f day)' to be written as just `day'. + (let ((byday* (if byday + (map (lambda (day) + (if (number? day) + (cons #f day) + day)) + byday) + #f))) + ;; TODO possibly check that until and count are mutually exclusive + (type-checker + freq until count interval bysecond byminute byhour + byday* bymonthday byyearday byweekno bymonth bysetpos + wkst) + (primitive-constructor + freq until count interval bysecond byminute byhour + byday* bymonthday byyearday byweekno bymonth bysetpos + wkst)))) + +(define (serialize-recur-rule record) + `(recur-rule + ,@(when (freq record) `(freq: ,(freq record))) + ,@(when (until record) `(until: ,(until record))) + ,@(when (count record) `(count: ,(count record))) + ,@(when (interval record) `(interval: ,(interval record))) + ,@(when (bysecond record) `(bysecond: ,(bysecond record))) + ,@(when (byminute record) `(byminute: ,(byminute record))) + ,@(when (byhour record) `(byhour: ,(byhour record))) + ,@(when (byday record) `(byday: ,(byday record))) + ,@(when (bymonthday record) `(bymonthday: ,(bymonthday record))) + ,@(when (byyearday record) `(byyearday: ,(byyearday record))) + ,@(when (byweekno record) `(byweekno: ,(byweekno record))) + ,@(when (bymonth record) `(bymonth: ,(bymonth record))) + ,@(when (bysetpos record) `(bysetpos: ,(bysetpos record))) + ,@(when (wkst record) `(wkst: ,(wkst record))))) + +;;; Both interval and wkst are optional by the standard. +;;; We however default those to 1 and monday in the constructor +;;; saving us from checking at the use site. +(define-type (recur-rule + constructor: recur-rule-constructor-factory + printer: (lambda (record port) + (pretty-print (serialize-recur-rule record) + port display?: #f))) + (freq type: (memv intervals)) + (until type: (or false? date? datetime?)) + (count type: (or false? (and integer? positive?))) + (interval type: (and integer? positive?)) + (bysecond type: (or false? (list-of (in-range? 0 60)))) + (byminute type: (or false? (list-of (in-range? 0 59)))) + (byhour type: (or false? (list-of (in-range? 0 23)))) + (byday type: (or false? (list-of (pair-of (or false? integer?) + (memv weekdays))))) + (bymonthday type: (or false? (list-of (and (not zero?) (in-range? -31 31))))) + (byyearday type: (or false? (list-of (and (not zero?) (in-range? -366 366))))) + (byweekno type: (or false? (list-of (and (not zero?) (in-range? -53 53))))) + (bymonth type: (or false? (list-of (and (not zero?) (in-range? -12 12))))) + (bysetpos type: (or false? (list-of (and (not zero?) (in-range? -366 366))))) + (wkst type: (memv weekdays))) (define (byday->string pair) diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index 12b6a622..ebe8b022 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -51,31 +51,6 @@ (cons (string->number (list->string numbers)) (rfc->datetime-weekday (apply symbol letters))))) -(define-macro (quick-case key . cases) - (let ((else-clause (or (assoc-ref cases 'else) - '(scm-error 'misc-error "quick-case" - "Guard failed" - #f #f)))) - `(case ,key - ,@(map (match-lambda - ((key guard '=> body ...) - `((,key) (if (not ,guard) - (begin (warning - "RRULE guard failed for key ~a~% guard: ~a : ~s" - (quote ,key) - (quote ,guard) - (map (lambda (o) (if (procedure? o) - (procedure-name o) - o)) - (list ,@guard))) - ,@else-clause) - (begin ,@body)))) - ((key body ...) - `((,key) (begin ,@body))) - (('else body ...) - `(else ,@body))) - cases)))) - (define* (string->number/throw string optional: (radix 10)) (or (string->number string radix) (scm-error 'wrong-type-arg @@ -87,55 +62,56 @@ ;; the same type as the DTSTART of the event (date or datetime). I have seen events ;; in the wild which didn't follow this. I consider that an user error. (define* (parse-recurrence-rule str optional: (datetime-parser parse-ics-datetime)) - (fold - (lambda (kv o) - (let ((key (car kv)) - (val (cadr kv))) - (let-lazy - ((symb (string->symbol val)) - ;; NOTE until MUST have the same value type as DTSTART - ;; on the object. Idealy we would save that type and - ;; check it here. That however is impractical since we - ;; might encounter the RRULE field before the DTSTART - ;; field. - (date (if (= 8 (string-length val)) - (parse-ics-date val) - (parse-ics-datetime val))) - (day (rfc->datetime-weekday (string->symbol val))) - (days (map parse-day-spec (string-split val #\,))) - (num (string->number/throw val)) - (nums (map string->number/throw (string-split val #\,)))) - - ;; It's an error to give BYHOUR and smaller for pure dates. - ;; 3.3.10. p 41 - (quick-case (string->symbol key) - (UNTIL (set (until o) date)) - - (COUNT (<= 0 num) => (set (count o) num)) - (INTERVAL (<= 0 num) => (set (interval o) num)) - - (FREQ (memv symb intervals) => (set (freq o) symb)) - (WKST (memv day weekdays) => (set (wkst o) day)) - - ;; Always positive - (BYSECOND (every (lambda (n) (<= 0 n 60)) nums) => (set (bysecond o) nums)) - (BYMINUTE (every (lambda (n) (<= 0 n 59)) nums) => (set (byminute o) nums)) - (BYHOUR (every (lambda (n) (<= 0 n 23)) nums) => (set (byhour o) nums)) - (BYMONTH (every (lambda (n) (<= 1 n 12)) nums) => (set (bymonth o) nums)) - - ;; May be negative - (BYDAY (every (lambda (p) (memv (cdr p) weekdays)) days) => (set (byday o) days)) - - (BYMONTHDAY (every (lambda (n) (and (!= n 0) (<= -31 n 31))) nums) => (set (bymonthday o) nums)) - (BYYEARDAY (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set (byyearday o) nums)) - (BYSETPOS (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set (bysetpos o) nums)) - (BYWEEKNO (every (lambda (n) (and (!= n 0) (<= -53 n 53))) nums) => (set (byweekno o) nums)) - - (else o))))) - - ;; obj - (make-recur-rule) - - ;; ((key val) ...) - (map (cut string-split <> #\=) - (string-split str #\;)))) + (define result + (fold + (lambda (kv o) + (let ((key (car kv)) + (val (cadr kv))) + (let-lazy + ((symb (string->symbol val)) + ;; NOTE until MUST have the same value type as DTSTART + ;; on the object. Idealy we would save that type and + ;; check it here. That however is impractical since we + ;; might encounter the RRULE field before the DTSTART + ;; field. + (date (if (= 8 (string-length val)) + (parse-ics-date val) + (parse-ics-datetime val))) + (day (rfc->datetime-weekday (string->symbol val))) + (days (map parse-day-spec (string-split val #\,))) + (num (string->number/throw val)) + (nums (map string->number/throw (string-split val #\,)))) + + ;; It's an error to give BYHOUR and smaller for pure dates. + ;; 3.3.10. p 41 + (case (string->symbol key) + ((UNTIL) (until o date)) + ((COUNT) (count o num)) + ((INTERVAL) (interval o num)) + ((FREQ) (freq o symb)) + ((WKST) (wkst o day)) + ((BYSECOND) (bysecond o nums)) + ((BYMINUTE) (byminute o nums)) + ((BYHOUR) (byhour o nums)) + ((BYMONH) (bymonth o nums)) + ((BYDAY) (byday o days)) + ((BYMONTHDAY) (bymonthday o nums)) + ((BYYEARDAY) (byyearday o nums)) + ((BYSETPOS) (bysetpos o nums)) + ((BYWEEKNO) (byweekno o nums)) + (else o))))) + + ;; obj + (recur-rule freq: (@ (vcomponent recurrence internal) freq-placeholder)) + + ;; ((key val) ...) + (map (cut string-split <> #\=) + (string-split str #\;)))) + + (when (eq? (@ (vcomponent recurrence internal) freq-placeholder) + (freq result)) + (scm-error 'wrong-type-arg + "parse-recurrence-rule" + "A valid for `freq' is required, but none supplied" + '() #f)) + result) -- cgit v1.2.3