Rename module vcalendar => vcomponent.

9 files changed, 628 insertions, 0 deletions

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-time<?)
+  )
+
+;;; date time pointer
+(define (parse-datetime dtime)
+  "Parse the given date[time] string into a date object."
+  (string->date
+   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 b)
+  (time<? (attr a 'DTSTART)
+          (attr b 'DTSTART)))
+
+;; Returns length of the event @var{e}, as a time-duration object.
+(define-public (event-length e)
+  (time-difference
+   (attr e 'DTEND)
+   (attr e 'DTSTART)))
+
+;; Returns the length of the part of @var{e} which is within the day
+;; starting at the time @var{start-of-day}.
+(define-public (event-length/day e start-of-day)
+  (time-difference
+   (time-min (add-day start-of-day) (attr e 'DTEND))
+   (time-max start-of-day (attr e 'DTSTART))))
diff --git a/module/vcomponent/output.scm b/module/vcomponent/output.scm
new file mode 100644
index 00000000..d5cf0f32
--- /dev/null
+++ b/module/vcomponent/output.scm
@@ -0,0 +1,96 @@
+(define-module (vcomponent output)
+  #:use-module (vcomponent)
+  #:use-module (vcomponent control)
+  #:use-module (util)
+  #:use-module (srfi srfi-19 util)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 format)
+  #:export (print-vcomponent
+            serialize-vcomponent
+            color-if
+            STR-YELLOW STR-RESET))
+
+(define STR-YELLOW "\x1b[0;33m")
+(define STR-RESET "\x1b[m")
+
+(define-syntax-rule (color-if pred color body ...)
+  (let ((pred-value pred))
+    (format #f "~a~a~a"
+            (if pred-value color "")
+            (begin body ...)
+            (if pred-value STR-RESET ""))))
+
+(define* (print-vcomponent comp #:optional (port #t) #:key (depth 0))
+  (let ((kvs (map (lambda (key) (cons key (attr* comp key)))
+                  (attributes comp))))
+    (format port "~a <~a> :: ~: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 <optional>.
+;; @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 <recur-rule> '(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 <recur-rule> f) r))
+  (with-output-to-string
+    (lambda ()
+      (format #t "#<recur-rule>~%")
+      (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 <recur-rule>)))))
+
+(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
+;; <weekday> ∈ weekdays
+;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO
+;; (<weekadynum>, ...)
+;; @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<?))
+  )
+
+;;@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
+
+;; 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-time<?
+               ;; { DAYLIGHT, STANDARD }
+               (map generate-recurrence-set (children tz)))))
+
+    (cond [(stream-null? strm) stream-null]
+
+          [(stream-null? (stream-drop 2 strm))
+           (let ((strm (extrapolate-tz-stream strm)))
+             (stream-zip strm (stream-cdr strm)))]
+
+          [else (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)))))
+