From 8f4fbcd493e28c86c598efcecdb6dc79d8fe0bfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 23 Apr 2019 18:03:49 +0200 Subject: Rename module vcalendar => vcomponent. --- module/vcalendar/recurrence/generate.scm | 137 ------------------------------- module/vcalendar/recurrence/internal.scm | 45 ---------- module/vcalendar/recurrence/parse.scm | 131 ----------------------------- 3 files changed, 313 deletions(-) delete mode 100644 module/vcalendar/recurrence/generate.scm delete mode 100644 module/vcalendar/recurrence/internal.scm delete mode 100644 module/vcalendar/recurrence/parse.scm (limited to 'module/vcalendar/recurrence') diff --git a/module/vcalendar/recurrence/generate.scm b/module/vcalendar/recurrence/generate.scm deleted file mode 100644 index 3baaa6eb..00000000 --- a/module/vcalendar/recurrence/generate.scm +++ /dev/null @@ -1,137 +0,0 @@ -(define-module (vcalendar recurrence generate) - #:use-module (srfi srfi-19) ; Datetime - #:use-module (srfi srfi-19 util) - #:use-module (srfi srfi-19 setters) - #:use-module (srfi srfi-26) ; Cut - #:use-module (srfi srfi-41) ; Streams - #:use-module (ice-9 match) - - #:use-module (util) - #:use-module (vcalendar) - #:use-module (vcalendar timezone) - #:use-module (vcalendar recurrence internal) - #:use-module (vcalendar recurrence parse) - - #:export (generate-recurrence-set) - ) - -;;; TODO implement -;;; EXDATE and RDATE - -;;; EXDATE (3.8.5.1) -;;; comma sepparated list of dates or datetimes. -;;; Can have TZID parameter -;;; Specifies list of dates that the event should not happen on, even -;;; if the RRULE say so. -;;; Can have VALUE field specifiying "DATE-TIME" or "DATE". - -;;; RDATE (3.8.5.2) -;;; Comma sepparated list of dates the event should happen on. -;;; Can have TZID parameter. -;;; Can have VALUE parameter, specyfying "DATE-TIME", "DATE" or "PREIOD". -;;; PERIOD (see 3.3.9) - -(define (seconds-in freq) - (case freq - ((SECONDLY) 1) - ((MINUTELY) 60) - ((HOURLY) (* 60 60)) - ((DAILY) (* 60 60 24)) - ((WEEKLY) (* 60 60 24 7)))) - -;; Event x Rule → Event -;; TODO My current naïve aproach to simple adding a constant time to an event -;; breaks with time-zones. betwen 12:00 two adjacent days might NOT be 24h. -;; Specifically, 23h or 25h when going between summer and "normal" time. -(define (next-event ev r) - (let* ((e (copy-vcomponent ev)) - (d (time-utc->date - (attr e 'DTSTART) - (if (prop (attr* ev 'DTSTART) 'TZID) - (get-tz-offset e) - 0)))) - - (let ((i (interval r))) - (case (freq r) - ((SECONDLY) (mod! (second d) = (+ i))) - ((MINUTELY) (mod! (minute d) = (+ i))) - ((HOURLY) (mod! (hour d) = (+ i))) - ((DAILY) (mod! (day d) = (+ i))) - ((WEEKLY) (mod! (day d) = (+ (* i 7)))) - ((MONTHLY) (mod! (month d) = (+ i))) - ((YEARLY) (mod! (year d) = (+ i))))) - - (set! (attr e 'DTSTART) - (date->time-utc d)) - - (when (prop (attr* e 'DTSTART) 'TZID) - (let ((of (get-tz-offset e))) - ;; This addition works, but we still get lunch at 13 - (set! (zone-offset d) of))) - - (set! (attr e 'DTSTART) - (date->time-utc d)) - - (when (attr e 'DTEND) - (set! (attr e 'DTEND) - (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) - - ;; Return - e)) - -;; BYDAY and the like depend on the freq? -;; Line 7100 -;; Table @@ 2430 -;; -;; Event x Rule → Bool (continue?) -;; Alternative, monadic solution using . -;; @example -;; (optional->bool -;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r)) -;; (<$> (negate zero?) (count r)) -;; (just #t))) -;; @end example -(define-stream (recur-event-stream event rule-obj) - (stream-unfold - - ;; Event x Rule → Event - car - - ;; Event x Rule → Bool (continue?) - (match-lambda - ((e r) - (or (and (not (until r)) (not (count r))) ; Never ending - (and=> (count r) (negate zero?)) ; COUNT - (and=> (until r) (cut time<=? (attr e 'DTSTART) <>))))) ; UNTIL - - ;; Event x Rule → next (Event, Rule) - (match-lambda - ((e r) - (list (next-event e r) - (if (count r) - ;; Note that this doesn't modify, since r is immutable. - (mod! (count r) 1-) - r )))) - - ;; Seed - (list event rule-obj))) - - -(define (generate-recurrence-set event) - ;; TODO DURATION might be used for something else, check applicable types - ;; TODO Far from all events have DTEND - ;; VTIMEZONE's always lack it. - (if (not (attr event 'RRULE)) - (stream event) - (begin - (when (and (attr event 'DTEND) - (not (attr event 'DURATION))) - (set! (attr event "DURATION") - (time-difference - (attr event "DTEND") - (attr event "DTSTART")))) - (if (attr event "RRULE") - (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))) - ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather - ;; just mention the current part. Handle this - stream-null)))) diff --git a/module/vcalendar/recurrence/internal.scm b/module/vcalendar/recurrence/internal.scm deleted file mode 100644 index 7a81b2db..00000000 --- a/module/vcalendar/recurrence/internal.scm +++ /dev/null @@ -1,45 +0,0 @@ -(define-module (vcalendar recurrence internal) - #:use-module (util) - #:use-module ((ice-9 optargs) #:select (define*-public)) - #:use-module (srfi srfi-88) - #:export (make-recur-rule - weekdays intervals)) - -;; Immutable, since I easily want to be able to generate the recurence set for -;; the same event multiple times. -(define-quick-record recur-rule - (public: freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst)) - -(define (make-recur-rule interval wkst) - ((record-constructor '(interval wkst)) interval wkst)) - -;; TODO make this part of define-quick-record. -;; Only "hard" part would be to provide type hints for fields for -;; string conversions. -(define-public (format-recur-rule r) - (define (a f) - ((record-accessor f) r)) - (with-output-to-string - (lambda () - (format #t "#~%") - (for-each - (lambda (field) - (when (a field) - (format #t " ~8@a: ~a~%" - field - ((case field - ((until) (@ (srfi srfi-19 util) time->string)) - (else identity)) - (a field))))) - (record-type-fields ))))) - -(define*-public (print-recur-rule r #:optional (port (current-output-port))) - (display (format-recur-rule r) port)) - -(define weekdays - '(SU MO TU WE TH FR SA)) - -(define intervals - '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) diff --git a/module/vcalendar/recurrence/parse.scm b/module/vcalendar/recurrence/parse.scm deleted file mode 100644 index 50d0e0a8..00000000 --- a/module/vcalendar/recurrence/parse.scm +++ /dev/null @@ -1,131 +0,0 @@ -(define-module (vcalendar recurrence parse) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) ; Datetime - #:use-module (srfi srfi-19 util) - #:use-module (srfi srfi-26) - #:use-module ((vcalendar datetime) #:select (parse-datetime)) - #:duplicates (last) ; Replace @var{count} - #:use-module (vcalendar recurrence internal) - #:use-module (util) - #:use-module (exceptions) - #:use-module (ice-9 curried-definitions) - #:export (parse-recurrence-rule)) - - -(define (printerr fmt . args) - (apply format (current-error-port) - fmt args)) - -(define (parse-recurrence-rule str) - (catch-multiple - (lambda () (%build-recur-rules str)) - - [unfulfilled-constraint - (cont obj key val . rest) - (printerr "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%" - err val key) - (cont #f)] - - [invalid-value - (cont obj key val . rest) - (printerr "ERR ~a [~a] for key [~a], ignoring.~%" - err val key) - (cont #f)])) - -(eval-when (expand) - (define ((handle-case stx obj) key val proc) - (with-syntax ((skey (datum->syntax - stx (symbol-downcase (syntax->datum key))))) - #`((#,key) - (let ((v #,val)) - (cond ((not v) (throw-returnable 'invalid-value #,obj (quote #,key) v)) - ((#,proc #,val) (set! (skey #,obj) v)) - (else (set! (skey #,obj) - (throw-returnable 'unfulfilled-constraint - #,obj (quote #,key) v))))))))) - - -;; A special form of case only useful in parse-recurrence-rules above. -;; Each case is on the form (KEY val check-proc) where: -;; `key` is what should be matched against, and what is used for the setter -;; `val` is the value to bind to the loop object and -;; `check` is something the object must conform to -(define-syntax quick-case - (lambda (stx) - (syntax-case stx () - ((_ var-key obj (key val proc) ...) - #`(case var-key - #,@(map (handle-case stx #'obj) - #'(key ...) - #'(val ...) - #'(proc ...)) - (else obj)))))) - -(define-syntax all-in - (syntax-rules () - ((_ var rules ...) - (cut every (lambda (var) (and rules ...)) <>)))) - -(define (string->number-list val delim) - (map string->number (string-split val delim))) - -(define (string->symbols val delim) - (map string->symbol (string-split val delim))) - -;; @example -;; ∈ weekdays -;; ::= [[±] ] ;; +3MO -;; (, ...) -;; @end example - -;; Returns a pair, where the @code{car} is the offset -;; and @code{cdr} is the day symbol. -;; The @code{car} may be @code{#f}. -(define (parse-day-spec str) - (let* ((numchars (append '(#\+ #\-) (map integer->char (iota 10 #x30)))) - (num symb (span (cut memv <> numchars) - (string->list str)))) - (cons (string->number (list->string num)) - (apply symbol symb)))) - -(define (%build-recur-rules str) - (fold - (lambda (kv obj) - (let* (((key val) kv) - ;; Lazy fields for the poor man. - (symb (lambda () (string->symbol val))) - (date (lambda () (date->time-utc (parse-datetime val)))) - (days (lambda () (map parse-day-spec (string-split val #\,)))) - (num (lambda () (string->number val))) - (nums (lambda () (string->number-list val #\,)))) - (quick-case (string->symbol key) obj - (FREQ (symb) (cut memv <> intervals)) ; Required - (UNTIL (date) identity) - (COUNT (num) (cut <= 0 <>)) - (INTERVAL (num) (cut <= 0 <>)) - (BYSECOND (nums) (all-in n (<= 0 n 60))) - (BYMINUTE (nums) (all-in n (<= 0 n 59))) - (BYHOUR (nums) (all-in n (<= 0 n 23))) - - (BYDAY (days) - (lambda (p*) - (map (lambda (p) - (let* (((num . symb) p)) - (memv symb weekdays))) - p*))) - - (BYMONTHDAY (nums) (all-in n (<= -31 n 31) (!= n 0))) - (BYYEARDAY (nums) (all-in n (<= -366 n 366) (!= n 0))) - (BYWEEKNO (nums) (all-in n (<= -53 n 53) (!= n 0))) - (BYMONTH (nums) (all-in n (<= 1 n 12))) - (BYSETPOS (nums) (all-in n (<= -366 n 366) (!= n 0))) - - (WKST (symb) (cut memv <> weekdays)) - ))) - - ;; obj - (make-recur-rule 1 'MO) - - ;; ((key val) ...) - (map (cut string-split <> #\=) - (string-split str #\;)))) -- cgit v1.2.3