Add earlier work on timezones.

Add earlier work on timezones, with a few inline modifications. This is
really to big of a commit. But we are so far from a stable release that
it should be fine.

The current version seems to eager, and recalculates to many times. This
will soon be fixed in a future version.

6 files changed, 162 insertions, 27 deletions

diff --git a/module/util.scm b/module/util.scm
index 25be0389..cdc6026d 100644
--- a/module/util.scm
+++ b/module/util.scm
@@ -152,8 +152,13 @@
             (set! rest ...)))))
 
 ;; Like set!, but applies a transformer on the already present value.
-(define-syntax-rule (mod! field transform-proc)
-  (set! field (transform-proc field)))
+(define-syntax mod!
+  (syntax-rules ()
+    ((_ field proc)
+     (set! field (proc field)))
+    ((_ field transform-proc rest ...)
+     (begin (set! field (transform-proc field))
+            (mod! rest ...)))))
 
 (define-public (concat lists)
   (apply append lists))
diff --git a/module/vcalendar.scm b/module/vcalendar.scm
index a4da1527..ef6fbd92 100644
--- a/module/vcalendar.scm
+++ b/module/vcalendar.scm
@@ -2,18 +2,50 @@
   #:use-module (vcalendar primitive)
   #:use-module (vcalendar datetime)
   #:use-module (vcalendar recur)
+  #:use-module (vcalendar timezone)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-19 util)
   #:use-module (srfi srfi-26)
   #: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 (unval parse-datetime)))
+
 (define (parse-dates! cal)
   "Parse all start times into scheme date objects."
-  (for-each-in (children cal 'VEVENT)
-               (lambda (ev)
-                 (mod! (attr ev "DTSTART") parse-datetime)
-                 (mod! (attr ev "DTEND")   parse-datetime)))
+
+  (for-each-in (children cal 'VTIMEZONE)
+               (lambda (tz)
+                 (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-each
+   (lambda (ev)
+     (mod! (attr ev "DTSTART") string->time-utc
+           (attr ev "DTEND")   string->time-utc)
+
+     (when (prop (attr* ev 'DTSTART) 'TZID)
+       (let* ((of (get-tz-offset ev)))
+         (set! (prop (attr* ev 'DTSTART) 'TZID) #f)
+         ;; 5545 says that DTEND is local time iff DTSTART is local time.
+         ;; But who says that will be true...
+         (mod! (attr ev 'DTSTART)
+               (cut subtract-duration <> (make-duration of))))))
+   (children cal 'VEVENT))
+
+  ;; Return
   cal)
 
 
diff --git a/module/vcalendar/datetime.scm b/module/vcalendar/datetime.scm
index f6df03d5..9b1cc82d 100644
--- a/module/vcalendar/datetime.scm
+++ b/module/vcalendar/datetime.scm
@@ -2,22 +2,24 @@
   #:use-module (vcalendar)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-19 util)
+  #:use-module (util)
 
   #:export (parse-datetime
             event-overlaps?
-            event-in?)
+            event-in?
+            ev-time<?)
   )
 
+;;; date time pointer
 (define (parse-datetime dtime)
   "Parse the given date[time] string into a date object."
-  ;; localize-date
-  (date->time-utc
-   (string->date
-    dtime
-    (case (string-length dtime)
-      ((8) "~Y~m~d")
-      ((15) "~Y~m~dT~H~M~S")
-      ((16) "~Y~m~dT~H~M~S~z")))))
+  (let* ((str type (case (string-length dtime)
+                     ((8) (values "~Y~m~d" 'all-day))        ; All day
+                     ((15) (values "~Y~m~dT~H~M~S" 'local))  ; "local" or TZID-param
+                     ((16) (values "~Y~m~dT~H~M~S~z" 'utc))  ; UTC-time
+                     ))
+         (date (string->date dtime str)))
+    (values date type)))
 
 (define (event-overlaps? event begin end)
   "Returns if the event overlaps the timespan.
@@ -33,6 +35,6 @@ Event must have the DTSTART and DTEND attribute set."
          (end (add-day start)))
     (event-overlaps? ev start end)))
 
-(define-public (ev-time<? a b)
+(define (ev-time<? a b)
   (time<? (attr a 'DTSTART)
           (attr b 'DTSTART)))
diff --git a/module/vcalendar/recurrence/generate.scm b/module/vcalendar/recurrence/generate.scm
index f585843f..2a5cfc91 100644
--- a/module/vcalendar/recurrence/generate.scm
+++ b/module/vcalendar/recurrence/generate.scm
@@ -1,6 +1,7 @@
 (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)
@@ -54,11 +55,20 @@
                      (seconds-in (freq r)))))))
 
      ((memv (freq r) '(MONTHLY YEARLY))
-      #f                                 ; Hur fasen beräkrnar man det här!!!!
-      ))
+      (let ((sdate (time-utc->date (attr e 'DTSTART))))
+        (case (freq r)
+          ((MONTHLY) (mod! (month sdate) (cut + <> (interval r))))
+          ((YEARLY)  (mod! (year sdate)  (cut + <> (interval r)))))
+        (set! (attr e 'DTSTART)
+              (date->time-utc sdate))))
 
-    (set! (attr e 'DTEND)
-          (add-duration (attr e 'DTSTART) (attr e 'DURATION)))
+     ;; TODO
+     ;; All the BY... fields
+     )
+
+    (when (attr e 'DTEND)
+     (set! (attr e 'DTEND)
+           (add-duration (attr e 'DTSTART) (attr e 'DURATION))))
 
     ;; Return
     e))
@@ -102,9 +112,20 @@
 
 
 (define (generate-recurrence-set event)
-  (unless (attr event "DURATION")
-    (set! (attr event "DURATION")
-          (time-difference
-           (attr event "DTEND")
-           (attr event "DTSTART"))))
-  (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))))
+  ;; 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/parse.scm b/module/vcalendar/recurrence/parse.scm
index ad8f06c3..de5d7e7c 100644
--- a/module/vcalendar/recurrence/parse.scm
+++ b/module/vcalendar/recurrence/parse.scm
@@ -87,7 +87,9 @@
      (let* (((key val) kv)
             ;; Lazy fields for the poor man.
             (symb (lambda () (string->symbol val)))
-            (date (lambda () (parse-datetime val)))
+            (date (lambda ()
+                   (let* ((date type (parse-datetime val)))
+                     (date->time-utc date))))
             (days (lambda () (map parse-day-spec (string-split val #\,))))
             (num  (lambda () (string->number val)))
             (nums (lambda () (string->number-list val #\,))))
diff --git a/module/vcalendar/timezone.scm b/module/vcalendar/timezone.scm
new file mode 100644
index 00000000..82d13a8d
--- /dev/null
+++ b/module/vcalendar/timezone.scm
@@ -0,0 +1,73 @@
+(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 recur) :select (generate-recurrence-set))
+  :use-module ((vcalendar datetime) :select (ev-time<?))
+  )
+
+;;@begin exampe
+;; <VTIMEZONE> :: "#<vcomponent 558c5da80fc0>"
+;;                  TZID: Europe/Stockholm
+;;        X-LIC-LOCATION: Europe/Stockholm
+;; : <DAYLIGHT> :: "#<vcomponent 558c5e11e7c0>"
+;; :                RRULE: FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU
+;; :              DTSTART: 19700329T020000
+;; :               TZNAME: CEST
+;; :           TZOFFSETTO: +0200
+;; :         TZOFFSETFROM: +0100
+;; : <STANDARD> :: "#<vcomponent 558c5e11e7e0>"
+;; :                RRULE: FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU
+;; :              DTSTART: 19701025T030000
+;; :               TZNAME: CET
+;; :           TZOFFSETTO: +0100
+;; :         TZOFFSETFROM: +0200
+;; @end example
+
+
+;; 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-time<?
+               ;; { DAYLIGHT, STANDARD }
+               (map generate-recurrence-set (children tz)))))
+    (if (stream-null? strm)
+        stream-null
+        (stream-zip strm (stream-cdr strm)))))
+
+(define (parse-offset str)
+  (let* (((pm h1 h0 m1 m0) (string->list 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<? (attr ev 'DTSTART) end))))
+              (attr (find-tz (parent ev)
+                             (car (prop (attr* ev 'DTSTART) 'TZID)))
+                    'X-HNH-TZSET))))
+    (if (not ret)
+        0 (parse-offset (attr (car ret) 'TZOFFSETTO)))))
+