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/fetch.scm | 6 +- module/html/html.scm | 12 +-- module/main.scm | 8 +- module/vcalendar.scm | 172 ------------------------------ module/vcalendar/control.scm | 39 ------- module/vcalendar/datetime.scm | 58 ---------- module/vcalendar/output.scm | 96 ----------------- module/vcalendar/primitive.scm | 22 ---- module/vcalendar/recurrence.scm | 12 --- module/vcalendar/recurrence/generate.scm | 137 ------------------------ module/vcalendar/recurrence/internal.scm | 45 -------- module/vcalendar/recurrence/parse.scm | 131 ----------------------- module/vcalendar/timezone.scm | 88 --------------- module/vcomponent.scm | 172 ++++++++++++++++++++++++++++++ module/vcomponent/control.scm | 39 +++++++ module/vcomponent/datetime.scm | 58 ++++++++++ module/vcomponent/output.scm | 96 +++++++++++++++++ module/vcomponent/primitive.scm | 22 ++++ module/vcomponent/recurrence.scm | 12 +++ module/vcomponent/recurrence/generate.scm | 137 ++++++++++++++++++++++++ module/vcomponent/recurrence/internal.scm | 45 ++++++++ module/vcomponent/recurrence/parse.scm | 131 +++++++++++++++++++++++ module/vcomponent/timezone.scm | 88 +++++++++++++++ tests/prop.scm | 2 +- tests/recurring.scm | 6 +- tests/rrule-parse.scm | 4 +- 26 files changed, 818 insertions(+), 820 deletions(-) delete mode 100644 module/vcalendar.scm delete mode 100644 module/vcalendar/control.scm delete mode 100644 module/vcalendar/datetime.scm delete mode 100644 module/vcalendar/output.scm delete mode 100644 module/vcalendar/primitive.scm delete mode 100644 module/vcalendar/recurrence.scm delete mode 100644 module/vcalendar/recurrence/generate.scm delete mode 100644 module/vcalendar/recurrence/internal.scm delete mode 100644 module/vcalendar/recurrence/parse.scm delete mode 100644 module/vcalendar/timezone.scm create mode 100644 module/vcomponent.scm create mode 100644 module/vcomponent/control.scm create mode 100644 module/vcomponent/datetime.scm create mode 100644 module/vcomponent/output.scm create mode 100644 module/vcomponent/primitive.scm create mode 100644 module/vcomponent/recurrence.scm create mode 100644 module/vcomponent/recurrence/generate.scm create mode 100644 module/vcomponent/recurrence/internal.scm create mode 100644 module/vcomponent/recurrence/parse.scm create mode 100644 module/vcomponent/timezone.scm diff --git a/module/fetch.scm b/module/fetch.scm index a91e4d0d..b01329a8 100755 --- a/module/fetch.scm +++ b/module/fetch.scm @@ -12,9 +12,9 @@ (use-modules (srfi srfi-1) (srfi srfi-19) (srfi srfi-26) - (vcalendar) - (vcalendar datetime) - (vcalendar output) + (vcomponent) + (vcomponent datetime) + (vcomponent output) (util)) diff --git a/module/html/html.scm b/module/html/html.scm index d7a52a53..44745ba0 100644 --- a/module/html/html.scm +++ b/module/html/html.scm @@ -2,14 +2,12 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-41) #:use-module (srfi srfi-41 util) - #:use-module (vcalendar) - #:use-module (vcalendar datetime) + #:use-module (vcomponent) + #:use-module (vcomponent datetime) #:use-module (util) #:use-module (util tree) #:use-module (srfi srfi-19) - #:use-module (srfi srfi-19 util) - - ) + #:use-module (srfi srfi-19 util)) (define-stream (group-stream in-stream) (define (ein? day) (lambda (e) (event-in? e (date->time-utc day)))) @@ -56,9 +54,9 @@ ;; smaller event. (sort* lst time>? (lambda (e) (event-length/day e start-of-day)))))) +;; This should only be used on time intervals, never on absolute times. +;; For that see @var{date->decimal-hour}. (define (time->decimal-hour time) - "This should only be used on time intervals, -never on absolute times. For that see date->decimal-hour" (exact->inexact (/ (time-second time) 3600))) diff --git a/module/main.scm b/module/main.scm index 1b38e6e2..6a2cd9c9 100755 --- a/module/main.scm +++ b/module/main.scm @@ -14,10 +14,10 @@ (ice-9 control) ; call-with-escape-continuation (texinfo string-utils) ; string->wrapped-lines (util) - (vcalendar) - (vcalendar recurrence) - (vcalendar datetime) - (vcalendar output) + (vcomponent) + (vcomponent recurrence) + (vcomponent datetime) + (vcomponent output) (terminal escape) (terminal util) diff --git a/module/vcalendar.scm b/module/vcalendar.scm deleted file mode 100644 index dbab308c..00000000 --- a/module/vcalendar.scm +++ /dev/null @@ -1,172 +0,0 @@ -(define-module (vcalendar) - #:use-module (vcalendar primitive) - #:use-module (vcalendar datetime) - #:use-module (vcalendar recurrence) - #:use-module (vcalendar timezone) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-19 util) - #:use-module (srfi srfi-19 setters) - #:use-module (srfi srfi-26) - #:use-module ((ice-9 optargs) #:select (define*-public)) - #:use-module (util) - #:export (make-vcomponent) - #:re-export (repeating?)) - -;; All VTIMEZONE's seem to be in "local" time in relation to -;; themselves. Therefore, a simple comparison should work, -;; and then the TZOFFSETTO attribute can be subtracted from -;; the event DTSTART to get UTC time. - -(define string->time-utc - (compose date->time-utc parse-datetime)) - -(define (parse-dates! cal) - "Parse all start times into scheme date objects." - - (for tz in (children cal 'VTIMEZONE) - (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc)) - (children tz)) - - ;; TZSET is the generated recurrence set of a timezone - (set! (attr tz 'X-HNH-TZSET) - (make-tz-set tz))) - - (for ev in (children cal 'VEVENT) - (define date (parse-datetime (attr ev 'DTSTART))) - (define end-date (parse-datetime (attr ev 'DTEND))) - - (set! (attr ev "DTSTART") (date->time-utc date) - (attr ev "DTEND") (date->time-utc end-date)) - - (when (prop (attr* ev 'DTSTART) 'TZID) - (set! (zone-offset date) (get-tz-offset ev) - (attr ev 'DTSTART) (date->time-utc date) - - ;; The standard says that DTEND must have the same - ;; timezone as DTSTART. Here we trust that blindly. - (zone-offset end-date) (zone-offset date) - (attr ev 'DTEND) (date->time-utc end-date)))) - - ;; Return - cal) - - -(define-public (type-filter t lst) - (filter (lambda (e) (eqv? t (type e))) - lst)) - -(define*-public (children component #:optional only-type) - (let ((childs (%vcomponent-children component))) - (if only-type - (type-filter only-type childs) - childs))) - -(define (get-attr component attr) - (%vcomponent-get-attribute - component - (as-string attr))) - -(define (set-attr! component attr value) - (set-car! (get-attr component (as-string attr)) - value)) - -(define-public attr* - (make-procedure-with-setter - get-attr set-attr!)) - -(define-public attr - (make-procedure-with-setter - (compose car get-attr) set-attr!)) - -;; value -(define-public v - (make-procedure-with-setter car set-car!)) - -(define-public prop - (make-procedure-with-setter - (lambda (attr-obj prop-key) - (hashq-ref (cdr attr-obj) prop-key)) - (lambda (attr-obj prop-key val) - (hashq-set! (cdr attr-obj) prop-key val)))) - -;; Returns the properties of attribute as an assoc list. -;; @code{(map car <>)} leads to available properties. -(define-public (properties attrptr) - (hash-map->list cons (cdr attrptr))) - -;; (define-public type %vcomponent-get-type) -(define-public type (make-procedure-with-setter - %vcomponent-get-type - %vcomponent-set-type!)) -(define-public parent %vcomponent-parent) -(define-public push-child! %vcomponent-push-child!) -(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component))) - -(define-public copy-vcomponent %vcomponent-shallow-copy) - -(define-public filter-children! %vcomponent-filter-children!) - -(define-public (extract field) - (lambda (e) (attr e field))) - -(define-public (extract* field) - (lambda (e) (attr* e field))) - -(define-public (search cal term) - (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) - (children cal)))) - (find (lambda (ev) (string-contains-ci (car ev) term)) - (map cons (map (extract "SUMMARY") - events) - events))))) - -(define-public (key=? k1 k2) - (eq? (as-symb k1) - (as-symb k2))) - -(define* (make-vcomponent #:optional path) - (if (not path) - (%vcomponent-make) - (let* ((root (%vcomponent-make path)) - (component - (parse-dates! - (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) - ;; == Single ICS file == - ;; Remove the abstract ROOT component, - ;; returning the wanted VCALENDAR component - ((file) - (car (%vcomponent-children root))) - - ;; == Assume vdir == - ;; Also removes the abstract ROOT component, but also - ;; merges all VCALENDAR's children into the first - ;; VCALENDAR, and return that VCALENDAR. - ;; - ;; TODO the other VCALENDAR components might not get thrown away, - ;; this since I protect them from the GC in the C code. - ((vdir) - (reduce (lambda (cal accum) - (for-each (lambda (component) - (case (type component) - ((VTIMEZONE) - (let ((zones (children accum 'VTIMEZONE))) - (unless (find (lambda (z) - (string=? (attr z "TZID") - (attr component "TZID"))) - zones) - (%vcomponent-push-child! accum component)))) - (else (%vcomponent-push-child! accum component)))) - (%vcomponent-children cal)) - accum) - '() (%vcomponent-children root))) - - ((no-type) (throw 'no-type)) - - (else (throw 'something)))))) - - (set! (attr component "NAME") - (attr root "NAME")) - (set! (attr component "COLOR") - (attr root "COLOR")) - component))) diff --git a/module/vcalendar/control.scm b/module/vcalendar/control.scm deleted file mode 100644 index a38d678f..00000000 --- a/module/vcalendar/control.scm +++ /dev/null @@ -1,39 +0,0 @@ -(define-module (vcalendar control) - #:use-module (util) - #:use-module (vcalendar) - #:export (with-replaced-attrs)) - - -(eval-when (expand load) ; No idea why I must have load here. - (define href (make-procedure-with-setter hashq-ref hashq-set!)) - - (define (set-temp-values! table component kvs) - (for-each (lambda (kv) - (let* (((key val) kv)) - (when (attr component key) - (set! (href table key) (attr component key)) - (set! (attr component key) val)))) - kvs)) - - (define (restore-values! table component keys) - (for-each (lambda (key) - (and=> (href table key) - (lambda (val) - (set! (attr component key) val)))) - keys))) - -;;; TODO with-added-attributes - -(define-syntax with-replaced-attrs - (syntax-rules () - [(_ (component (key val) ...) - body ...) - - (let ((htable (make-hash-table 10))) - (dynamic-wind - (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard - (lambda () body ...) - (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard - -;;; TODO test that restore works, at all -;;; Test that non-local exit and return works diff --git a/module/vcalendar/datetime.scm b/module/vcalendar/datetime.scm deleted file mode 100644 index 1e5b5853..00000000 --- a/module/vcalendar/datetime.scm +++ /dev/null @@ -1,58 +0,0 @@ -(define-module (vcalendar datetime) - #:use-module (vcalendar) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-19 util) - #:use-module (util) - - #:export (parse-datetime - event-overlaps? - overlapping? - event-in? - ev-timedate - dtime (case (string-length dtime) - ((8) "~Y~m~d") ; All day - ((15) "~Y~m~dT~H~M~S") ; "local" or TZID-param - ((16) "~Y~m~dT~H~M~S~z")))) ; UTC-time - -(define (event-overlaps? event begin end) - "Returns if the event overlaps the timespan. -Event must have the DTSTART and DTEND attribute set." - (timespan-overlaps? (attr event 'DTSTART) - (attr event 'DTEND) - begin end)) - -(define (overlapping? event-a event-b) - (timespan-overlaps? (attr event-a 'DTSTART) - (attr event-a 'DTEND) - (attr event-b 'DTSTART) - (attr event-b 'DTEND))) - -(define (event-in? ev time) - "Does event overlap the date that contains time." - (let* ((date (time-utc->date time)) - (start (date->time-utc (drop-time date))) - (end (add-day start))) - (event-overlaps? ev start end))) - -(define (ev-time :: ~:a~%" - (make-string depth #\:) - (type comp) comp) - (for-each-in kvs - (lambda (kv) - (let* (((key . at) kv)) - (format port "~a ~15@a~{;~a=~{~a~^,~}~}: ~a~%" - (make-string depth #\:) - key - (concat (hash-map->list list (cdr at))) - (v at))))) - (for-each-in (children comp) - (lambda (e) (print-vcomponent e port #:depth (1+ depth)))))) - - - -;;; TODO -;; Error in CREATED /home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/a1a25238-d63d-46a1-87fd-d0c9334a7a30CalSync.ics: -;; Wrong type argument in position 1 (expecting string): ("20180118T124015Z" "VALARM") - -(define (string->ics-safe-string str) - "TODO wrap at 75(?) columns." - (define (escape char) - (string #\\ char)) - - (string-concatenate - (map (lambda (c) - (case c - ((#\newline) "\\n") - ((#\, #\; #\\) => escape) - (else => string))) - (string->list str)))) - -;;; TODO parameters ( ;KEY=val: ) -(define* (serialize-vcomponent comp #:optional (port (current-output-port))) - "Recursively write a component back to its ICS form. -Removes the X-HNH-FILENAME attribute, and sets PRODID to -\"HugoNikanor-calparse\" in the output." - (with-replaced-attrs - (comp (prodid "HugoNikanor-calparse")) - - (format port "BEGIN:~a~%" (type comp)) - (let ((kvs (map (lambda (key) (list key (attr comp key))) - (filter (negate (cut key=? <> 'X-HNH-FILENAME)) - (attributes comp))))) - (for-each-in - kvs (lambda (kv) - (let* (((key value) kv)) - (catch 'wrong-type-arg - (lambda () - (format port "~a:~a~%" key - (string->ics-safe-string - (or (case key - ((DTSTART DTEND) - (if (string? value) - value - (time->string value "~Y~m~dT~H~M~S"))) - - ((DURATION) "Just forget it") - - (else value)) - "")))) - - ;; Catch - (lambda (type proc fmt . args) - (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%" - type key proc (attr comp 'X-HNH-FILENAME) - fmt args)))))) - - (for-each (cut serialize-vcomponent <> port) (children comp))) - (format port "END:~a~%" (type comp)))) diff --git a/module/vcalendar/primitive.scm b/module/vcalendar/primitive.scm deleted file mode 100644 index 27ae6e17..00000000 --- a/module/vcalendar/primitive.scm +++ /dev/null @@ -1,22 +0,0 @@ -;;; Primitive export of symbols linked from C binary. - -(define-module (vcalendar primitive) - #:export (%vcomponent-children - %vcomponent-push-child! - %vcomponent-filter-children! - - %vcomponent-parent - - %vcomponent-make - %vcomponent-get-type - %vcomponent-set-type! - - %vcomponent-get-attribute - %vcomponent-attribute-list - - %vcomponent-shallow-copy)) - -(setenv "LD_LIBRARY_PATH" - (string-append (dirname (dirname (dirname (current-filename)))) - "/lib")) -(load-extension "libguile-calendar" "init_lib") diff --git a/module/vcalendar/recurrence.scm b/module/vcalendar/recurrence.scm deleted file mode 100644 index ae08feb6..00000000 --- a/module/vcalendar/recurrence.scm +++ /dev/null @@ -1,12 +0,0 @@ -(define-module (vcalendar recurrence) - #:use-module (vcalendar) - #:use-module (vcalendar recurrence generate) - #:re-export (generate-recurrence-set) - #:export (repeating?)) - -;; EXDATE is also a property linked to recurense rules -;; but that property alone don't create a recuring event. -(define (repeating? ev) - "Does this event repeat?" - (or (attr ev 'RRULE) - (attr ev 'RDATE))) 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 #\;)))) diff --git a/module/vcalendar/timezone.scm b/module/vcalendar/timezone.scm deleted file mode 100644 index 560289d4..00000000 --- a/module/vcalendar/timezone.scm +++ /dev/null @@ -1,88 +0,0 @@ -(define-module (vcalendar timezone) - :use-module (vcalendar) - :use-module ((srfi srfi-1) :select (find)) - :use-module (srfi srfi-19) - :use-module (srfi srfi-19 util) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module (util) - :use-module ((vcalendar recurrence generate) :select (generate-recurrence-set)) - :use-module ((vcalendar datetime) :select (ev-time :: "#" -;; TZID: Europe/Stockholm -;; X-LIC-LOCATION: Europe/Stockholm -;; : :: "#" -;; : RRULE: FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU -;; : DTSTART: 19700329T020000 -;; : TZNAME: CEST -;; : TZOFFSETTO: +0200 -;; : TZOFFSETFROM: +0100 -;; : :: "#" -;; : RRULE: FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU -;; : DTSTART: 19701025T030000 -;; : TZNAME: CET -;; : TZOFFSETTO: +0100 -;; : TZOFFSETFROM: +0200 -;; @end example - -;; Given a tz stream of length 2, takes the time difference between the DTSTART -;; of those two. And creates a new VTIMEZONE with that end time. -;; TODO set remaining properties, and type of the newly created component. -(define (extrapolate-tz-stream strm) - (let ((nevent (copy-vcomponent (stream-ref strm 1)))) - (mod! (attr nevent 'DTSTART) - = (add-duration (time-difference - (attr (stream-ref strm 1) 'DTSTART) - (attr (stream-ref strm 0) 'DTSTART)))) - (stream-append strm (stream nevent)))) - -;; The RFC requires that at least one DAYLIGHT or STANDARD component is present. -;; Any number of both can be present. This should handle all these cases well, -;; as long as noone has multiple overlapping timezones, which depend on some -;; further condition. That feels like something that should be impossible, but -;; this is (human) time we are talking about. -(define-public (make-tz-set tz) - (let ((strm (interleave-streams - ev-timelist str))) - ((primitive-eval (symbol pm)) - (+ (* 60 (string->number (list->string (list m1 m0)))) - (* 60 60 (string->number (list->string (list h1 h0)))))))) - -;; Finds the VTIMEZONE with id @var{tzid} in calendar. -;; Crashes on error. -(define (find-tz cal tzid) - (let ((ret (find (lambda (tz) (string=? tzid (attr tz 'TZID))) - (children cal 'VTIMEZONE)))) - ret)) - -;; Takes a VEVENT. -;; Assumes that DTSTART has a TZID property, and that that TZID is available as -;; a direct child of the parent of @var{ev}. -(define-public (get-tz-offset ev) - (let ((ret (stream-find - (lambda (z) - (let* (((start end) (map (extract 'DTSTART) z))) - (and (time<=? start (attr ev 'DTSTART)) - (timetime-utc + (compose date->time-utc parse-datetime)) + +(define (parse-dates! cal) + "Parse all start times into scheme date objects." + + (for tz in (children cal 'VTIMEZONE) + (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc)) + (children tz)) + + ;; TZSET is the generated recurrence set of a timezone + (set! (attr tz 'X-HNH-TZSET) + (make-tz-set tz))) + + (for ev in (children cal 'VEVENT) + (define date (parse-datetime (attr ev 'DTSTART))) + (define end-date (parse-datetime (attr ev 'DTEND))) + + (set! (attr ev "DTSTART") (date->time-utc date) + (attr ev "DTEND") (date->time-utc end-date)) + + (when (prop (attr* ev 'DTSTART) 'TZID) + (set! (zone-offset date) (get-tz-offset ev) + (attr ev 'DTSTART) (date->time-utc date) + + ;; The standard says that DTEND must have the same + ;; timezone as DTSTART. Here we trust that blindly. + (zone-offset end-date) (zone-offset date) + (attr ev 'DTEND) (date->time-utc end-date)))) + + ;; Return + cal) + + +(define-public (type-filter t lst) + (filter (lambda (e) (eqv? t (type e))) + lst)) + +(define*-public (children component #:optional only-type) + (let ((childs (%vcomponent-children component))) + (if only-type + (type-filter only-type childs) + childs))) + +(define (get-attr component attr) + (%vcomponent-get-attribute + component + (as-string attr))) + +(define (set-attr! component attr value) + (set-car! (get-attr component (as-string attr)) + value)) + +(define-public attr* + (make-procedure-with-setter + get-attr set-attr!)) + +(define-public attr + (make-procedure-with-setter + (compose car get-attr) set-attr!)) + +;; value +(define-public v + (make-procedure-with-setter car set-car!)) + +(define-public prop + (make-procedure-with-setter + (lambda (attr-obj prop-key) + (hashq-ref (cdr attr-obj) prop-key)) + (lambda (attr-obj prop-key val) + (hashq-set! (cdr attr-obj) prop-key val)))) + +;; Returns the properties of attribute as an assoc list. +;; @code{(map car <>)} leads to available properties. +(define-public (properties attrptr) + (hash-map->list cons (cdr attrptr))) + +;; (define-public type %vcomponent-get-type) +(define-public type (make-procedure-with-setter + %vcomponent-get-type + %vcomponent-set-type!)) +(define-public parent %vcomponent-parent) +(define-public push-child! %vcomponent-push-child!) +(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component))) + +(define-public copy-vcomponent %vcomponent-shallow-copy) + +(define-public filter-children! %vcomponent-filter-children!) + +(define-public (extract field) + (lambda (e) (attr e field))) + +(define-public (extract* field) + (lambda (e) (attr* e field))) + +(define-public (search cal term) + (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) + (children cal)))) + (find (lambda (ev) (string-contains-ci (car ev) term)) + (map cons (map (extract "SUMMARY") + events) + events))))) + +(define-public (key=? k1 k2) + (eq? (as-symb k1) + (as-symb k2))) + +(define* (make-vcomponent #:optional path) + (if (not path) + (%vcomponent-make) + (let* ((root (%vcomponent-make path)) + (component + (parse-dates! + (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) + ;; == Single ICS file == + ;; Remove the abstract ROOT component, + ;; returning the wanted VCALENDAR component + ((file) + (car (%vcomponent-children root))) + + ;; == Assume vdir == + ;; Also removes the abstract ROOT component, but also + ;; merges all VCALENDAR's children into the first + ;; VCALENDAR, and return that VCALENDAR. + ;; + ;; TODO the other VCALENDAR components might not get thrown away, + ;; this since I protect them from the GC in the C code. + ((vdir) + (reduce (lambda (cal accum) + (for-each (lambda (component) + (case (type component) + ((VTIMEZONE) + (let ((zones (children accum 'VTIMEZONE))) + (unless (find (lambda (z) + (string=? (attr z "TZID") + (attr component "TZID"))) + zones) + (%vcomponent-push-child! accum component)))) + (else (%vcomponent-push-child! accum component)))) + (%vcomponent-children cal)) + accum) + '() (%vcomponent-children root))) + + ((no-type) (throw 'no-type)) + + (else (throw 'something)))))) + + (set! (attr component "NAME") + (attr root "NAME")) + (set! (attr component "COLOR") + (attr root "COLOR")) + component))) diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm new file mode 100644 index 00000000..38199161 --- /dev/null +++ b/module/vcomponent/control.scm @@ -0,0 +1,39 @@ +(define-module (vcomponent control) + #:use-module (util) + #:use-module (vcomponent) + #:export (with-replaced-attrs)) + + +(eval-when (expand load) ; No idea why I must have load here. + (define href (make-procedure-with-setter hashq-ref hashq-set!)) + + (define (set-temp-values! table component kvs) + (for-each (lambda (kv) + (let* (((key val) kv)) + (when (attr component key) + (set! (href table key) (attr component key)) + (set! (attr component key) val)))) + kvs)) + + (define (restore-values! table component keys) + (for-each (lambda (key) + (and=> (href table key) + (lambda (val) + (set! (attr component key) val)))) + keys))) + +;;; TODO with-added-attributes + +(define-syntax with-replaced-attrs + (syntax-rules () + [(_ (component (key val) ...) + body ...) + + (let ((htable (make-hash-table 10))) + (dynamic-wind + (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard + (lambda () body ...) + (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard + +;;; TODO test that restore works, at all +;;; Test that non-local exit and return works diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm new file mode 100644 index 00000000..2270d10e --- /dev/null +++ b/module/vcomponent/datetime.scm @@ -0,0 +1,58 @@ +(define-module (vcomponent datetime) + #:use-module (vcomponent) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) + #:use-module (util) + + #:export (parse-datetime + event-overlaps? + overlapping? + event-in? + ev-timedate + dtime (case (string-length dtime) + ((8) "~Y~m~d") ; All day + ((15) "~Y~m~dT~H~M~S") ; "local" or TZID-param + ((16) "~Y~m~dT~H~M~S~z")))) ; UTC-time + +(define (event-overlaps? event begin end) + "Returns if the event overlaps the timespan. +Event must have the DTSTART and DTEND attribute set." + (timespan-overlaps? (attr event 'DTSTART) + (attr event 'DTEND) + begin end)) + +(define (overlapping? event-a event-b) + (timespan-overlaps? (attr event-a 'DTSTART) + (attr event-a 'DTEND) + (attr event-b 'DTSTART) + (attr event-b 'DTEND))) + +(define (event-in? ev time) + "Does event overlap the date that contains time." + (let* ((date (time-utc->date time)) + (start (date->time-utc (drop-time date))) + (end (add-day start))) + (event-overlaps? ev start end))) + +(define (ev-time :: ~:a~%" + (make-string depth #\:) + (type comp) comp) + (for-each-in kvs + (lambda (kv) + (let* (((key . at) kv)) + (format port "~a ~15@a~{;~a=~{~a~^,~}~}: ~a~%" + (make-string depth #\:) + key + (concat (hash-map->list list (cdr at))) + (v at))))) + (for-each-in (children comp) + (lambda (e) (print-vcomponent e port #:depth (1+ depth)))))) + + + +;;; TODO +;; Error in CREATED /home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/a1a25238-d63d-46a1-87fd-d0c9334a7a30CalSync.ics: +;; Wrong type argument in position 1 (expecting string): ("20180118T124015Z" "VALARM") + +(define (string->ics-safe-string str) + "TODO wrap at 75(?) columns." + (define (escape char) + (string #\\ char)) + + (string-concatenate + (map (lambda (c) + (case c + ((#\newline) "\\n") + ((#\, #\; #\\) => escape) + (else => string))) + (string->list str)))) + +;;; TODO parameters ( ;KEY=val: ) +(define* (serialize-vcomponent comp #:optional (port (current-output-port))) + "Recursively write a component back to its ICS form. +Removes the X-HNH-FILENAME attribute, and sets PRODID to +\"HugoNikanor-calparse\" in the output." + (with-replaced-attrs + (comp (prodid "HugoNikanor-calparse")) + + (format port "BEGIN:~a~%" (type comp)) + (let ((kvs (map (lambda (key) (list key (attr comp key))) + (filter (negate (cut key=? <> 'X-HNH-FILENAME)) + (attributes comp))))) + (for-each-in + kvs (lambda (kv) + (let* (((key value) kv)) + (catch 'wrong-type-arg + (lambda () + (format port "~a:~a~%" key + (string->ics-safe-string + (or (case key + ((DTSTART DTEND) + (if (string? value) + value + (time->string value "~Y~m~dT~H~M~S"))) + + ((DURATION) "Just forget it") + + (else value)) + "")))) + + ;; Catch + (lambda (type proc fmt . args) + (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%" + type key proc (attr comp 'X-HNH-FILENAME) + fmt args)))))) + + (for-each (cut serialize-vcomponent <> port) (children comp))) + (format port "END:~a~%" (type comp)))) diff --git a/module/vcomponent/primitive.scm b/module/vcomponent/primitive.scm new file mode 100644 index 00000000..b583d454 --- /dev/null +++ b/module/vcomponent/primitive.scm @@ -0,0 +1,22 @@ +;;; Primitive export of symbols linked from C binary. + +(define-module (vcomponent primitive) + #:export (%vcomponent-children + %vcomponent-push-child! + %vcomponent-filter-children! + + %vcomponent-parent + + %vcomponent-make + %vcomponent-get-type + %vcomponent-set-type! + + %vcomponent-get-attribute + %vcomponent-attribute-list + + %vcomponent-shallow-copy)) + +(setenv "LD_LIBRARY_PATH" + (string-append (dirname (dirname (dirname (current-filename)))) + "/lib")) +(load-extension "libguile-calendar" "init_lib") diff --git a/module/vcomponent/recurrence.scm b/module/vcomponent/recurrence.scm new file mode 100644 index 00000000..d1113477 --- /dev/null +++ b/module/vcomponent/recurrence.scm @@ -0,0 +1,12 @@ +(define-module (vcomponent recurrence) + #:use-module (vcomponent) + #:use-module (vcomponent recurrence generate) + #:re-export (generate-recurrence-set) + #:export (repeating?)) + +;; EXDATE is also a property linked to recurense rules +;; but that property alone don't create a recuring event. +(define (repeating? ev) + "Does this event repeat?" + (or (attr ev 'RRULE) + (attr ev 'RDATE))) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm new file mode 100644 index 00000000..9b611ecd --- /dev/null +++ b/module/vcomponent/recurrence/generate.scm @@ -0,0 +1,137 @@ +(define-module (vcomponent 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 (vcomponent) + #:use-module (vcomponent timezone) + #:use-module (vcomponent recurrence internal) + #:use-module (vcomponent 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/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm new file mode 100644 index 00000000..f7095d1d --- /dev/null +++ b/module/vcomponent/recurrence/internal.scm @@ -0,0 +1,45 @@ +(define-module (vcomponent 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/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm new file mode 100644 index 00000000..7df0e2e6 --- /dev/null +++ b/module/vcomponent/recurrence/parse.scm @@ -0,0 +1,131 @@ +(define-module (vcomponent 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 ((vcomponent datetime) #:select (parse-datetime)) + #:duplicates (last) ; Replace @var{count} + #:use-module (vcomponent 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 #\;)))) diff --git a/module/vcomponent/timezone.scm b/module/vcomponent/timezone.scm new file mode 100644 index 00000000..5b262f1c --- /dev/null +++ b/module/vcomponent/timezone.scm @@ -0,0 +1,88 @@ +(define-module (vcomponent timezone) + :use-module (vcomponent) + :use-module ((srfi srfi-1) :select (find)) + :use-module (srfi srfi-19) + :use-module (srfi srfi-19 util) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (util) + :use-module ((vcomponent recurrence generate) :select (generate-recurrence-set)) + :use-module ((vcomponent datetime) :select (ev-time :: "#" +;; TZID: Europe/Stockholm +;; X-LIC-LOCATION: Europe/Stockholm +;; : :: "#" +;; : RRULE: FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU +;; : DTSTART: 19700329T020000 +;; : TZNAME: CEST +;; : TZOFFSETTO: +0200 +;; : TZOFFSETFROM: +0100 +;; : :: "#" +;; : RRULE: FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU +;; : DTSTART: 19701025T030000 +;; : TZNAME: CET +;; : TZOFFSETTO: +0100 +;; : TZOFFSETFROM: +0200 +;; @end example + +;; Given a tz stream of length 2, takes the time difference between the DTSTART +;; of those two. And creates a new VTIMEZONE with that end time. +;; TODO set remaining properties, and type of the newly created component. +(define (extrapolate-tz-stream strm) + (let ((nevent (copy-vcomponent (stream-ref strm 1)))) + (mod! (attr nevent 'DTSTART) + = (add-duration (time-difference + (attr (stream-ref strm 1) 'DTSTART) + (attr (stream-ref strm 0) 'DTSTART)))) + (stream-append strm (stream nevent)))) + +;; The RFC requires that at least one DAYLIGHT or STANDARD component is present. +;; Any number of both can be present. This should handle all these cases well, +;; as long as noone has multiple overlapping timezones, which depend on some +;; further condition. That feels like something that should be impossible, but +;; this is (human) time we are talking about. +(define-public (make-tz-set tz) + (let ((strm (interleave-streams + ev-timelist str))) + ((primitive-eval (symbol pm)) + (+ (* 60 (string->number (list->string (list m1 m0)))) + (* 60 60 (string->number (list->string (list h1 h0)))))))) + +;; Finds the VTIMEZONE with id @var{tzid} in calendar. +;; Crashes on error. +(define (find-tz cal tzid) + (let ((ret (find (lambda (tz) (string=? tzid (attr tz 'TZID))) + (children cal 'VTIMEZONE)))) + ret)) + +;; Takes a VEVENT. +;; Assumes that DTSTART has a TZID property, and that that TZID is available as +;; a direct child of the parent of @var{ev}. +(define-public (get-tz-offset ev) + (let ((ret (stream-find + (lambda (z) + (let* (((start end) (map (extract 'DTSTART) z))) + (and (time<=? start (attr ev 'DTSTART)) + (time) + ((record-constructor (@@ (vcomponent recurrence internal) ) (quote (key ...))) (quote val) ...)))) -- cgit v1.2.3