From f852c30bcef530d18a474ab6ab8350a3ef93d563 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Jan 2020 22:51:45 +0100 Subject: Once again compiles. --- module/vcomponent/datetime.scm | 16 +++++++---- module/vcomponent/group.scm | 10 +++---- module/vcomponent/load.scm | 8 +++++- module/vcomponent/output.scm | 15 +++++++--- module/vcomponent/parse.scm | 7 ++++- module/vcomponent/recurrence/generate.scm | 46 +++++++++++++++++++------------ module/vcomponent/recurrence/internal.scm | 3 +- module/vcomponent/recurrence/parse.scm | 22 ++++++++++----- 8 files changed, 86 insertions(+), 41 deletions(-) (limited to 'module/vcomponent') diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index c01de7e7..765c065d 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -34,9 +34,9 @@ Event must have the DTSTART and DTEND attribute set." (attr event-b 'DTSTART) (attr event-b 'DTEND))) -(define (event-contains? ev datetime) +(define (event-contains? ev date/-time) "Does event overlap the date that contains time." - (let* ((start (get-date datetime)) + (let* ((start (as-date date/-time)) (end (add-day start))) (event-overlaps? ev start end))) @@ -52,8 +52,14 @@ Event must have the DTSTART and DTEND attribute set." ;; 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) +;; currently the secund argument is a date, but should possibly be changed +;; to a datetime to allow for more explicit TZ handling? +(define-public (event-length/day e) (time- - (time-min (add-day start-of-day) (attr e 'DTEND)) - (time-max start-of-day (attr e 'DTSTART)))) + (time-min #00:00:00 (as-time (attr e 'DTEND))) + (time-max #24:00:00 (as-time (attr e 'DTSTART))))) + +;; 22:00 - 03:00 +;; 2h för dag 1 +;; 3h för dag 2 diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm index acf41999..83d79f9a 100644 --- a/module/vcomponent/group.scm +++ b/module/vcomponent/group.scm @@ -9,14 +9,14 @@ ;; TODO templetize this (define-stream (group-stream in-stream) - (define (ein? day) (lambda (e) (event-contains? e (date->time-utc day)))) + (define (ein? day) (lambda (e) (event-contains? e day))) - (let loop ((days (day-stream (time-utc->date (attr (stream-car in-stream) 'DTSTART)))) + (let loop ((days (day-stream (as-date (attr (stream-car in-stream) 'DTSTART)))) (stream in-stream)) (if (stream-null? stream) stream-null (let* ((day (stream-car days)) - (tomorow (date->time-utc (stream-car (stream-cdr days))))) + (tomorow (stream-car (stream-cdr days)))) (let ((head (stream-take-while (ein? day) stream)) (tail @@ -26,8 +26,8 @@ ;; of tommorow, and finishes with the rest when it finds the first ;; object which begins tomorow (after midnight, exclusize). (filter-sorted-stream* - (lambda (e) (timestream regular) + #; (interleave-streams ev-timestream regular) - (map generate-recurrence-set repeating)))))) + '() + ;; TODO reactivate this + #; (map generate-recurrence-set repeating) + ))))) ;; Basic version, loads calendrs, sorts the events, and returns ;; regular and repeating events separated from each other. diff --git a/module/vcomponent/output.scm b/module/vcomponent/output.scm index 14c1bf13..55cc0b12 100644 --- a/module/vcomponent/output.scm +++ b/module/vcomponent/output.scm @@ -3,7 +3,8 @@ #:use-module (vcomponent control) #:use-module (util) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-19 alt) + #:use-module (srfi srfi-19 alt util) #:use-module (srfi srfi-26) #:use-module (ice-9 format) #:export (print-vcomponent @@ -66,9 +67,15 @@ Removes the X-HNH-FILENAME attribute, and sets PRODID to (string->ics-safe-string (case key ((DTSTART DTEND) - (if (string? value) - value - (time->string value "~Y~m~dT~H~M~S"))) + (cond [(string? value) value] + [(date? value) (date->string value "~H~M~S")] + [(datetime? value) + (string-append + (date->string (get-date value) "~Y~m~d") + "T" + (time->string (get-time value) "~H~M~S"))])) + ((X-HNH-DURATION) + (format #f "~s" value)) (else value))))) ;; Catch diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 646d1f72..24becd13 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -167,7 +167,12 @@ (mod! (value it) (if (or (and=>> v car (cut string=? <> "DATE-TIME")) (string-contains (value it) "T")) - parse-datetime parse-date)))] + (begin + (set! (prop it 'VALUE) "DATE-TIME") + parse-datetime) + (begin + (set! (prop it 'VALUE) "DATE") + parse-date))))] ) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 938d99f9..8a4eed36 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -142,20 +142,32 @@ ;; 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 - (set! (attr event 'X-HNH-DURATION) - (cond [(attr event 'DURATION) => identity] - [(attr event 'DTEND) - => (lambda (end) - ;; The value type of dtstart and dtend must be the same - ;; according to RFC 5545 3.8.2.2 (Date-Time End). - (if (date? end) - (date- end (attr event 'DTSTART)) - (datetime- end (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)))) + (catch #t + (lambda () + (if (not (attr event 'RRULE)) + (stream event) + (begin + (set! (attr event 'X-HNH-DURATION) + (cond [(attr event 'DURATION) => identity] + [(attr event 'DTEND) + => (lambda (end) + ;; The value type of dtstart and dtend must be the same + ;; according to RFC 5545 3.8.2.2 (Date-Time End). + (if (date? end) + (date- end (attr event 'DTSTART)) + (datetime- end (attr event 'DTSTART))))])) + (if (attr event "RRULE") + (recur-event-stream event (parse-recurrence-rule + (attr event "RRULE") + (if (string= "DATE" (and=> (prop (attr* event 'DTSTART) 'VALUE) car)) + parse-date parse-datetime))) + ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather + ;; just mention the current part. Handle this + stream-null)))) + (lambda (err . args) + (format (current-error-port) + "\x1b[0;31mError\x1b[m while parsing recurrence rule (ignoring and continuing)~%~a ~a~%~a~%~%" + err args + (attr event 'X-HNH-FILENAME)) + (stream ; event + )))) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 12cf7a7b..50c44a60 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -37,7 +37,8 @@ (display "=" port) (display (case field - ((until) ((@ (srfi srfi-19 util) time->string) it)) + ;; TODO check over date/time/datetime here + ((until) ((@ (srfi srfi-19 alt util) time->string) it)) (else it)) port))) (display ">" port)))))) diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index f532987a..1c974727 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -18,15 +18,20 @@ ;; (, ...) ;; @end example +;;; weekdaynum can contain ± +;;; only used in bywdaylist +;;; only present with by BYDAY + ;; Returns a pair, where the @code{car} is the offset ;; and @code{cdr} is the day symbol. ;; The @code{car} may be @code{#f}. +;; str → ( . ) (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)))) + (let* ((numerical-characters (append '(#\+ #\-) (map integer->char (iota 10 #x30)))) + (numbers letters (span (cut memv <> numerical-characters) + (string->list str)))) + (cons (string->number (list->string numbers)) + (apply symbol letters)))) (define-macro (quick-case key . cases) (let ((else-clause (or (assoc-ref cases 'else) @@ -43,17 +48,20 @@ `(else ,@body))) cases)))) -(define (parse-recurrence-rule str) +;; UNTIL must have the exact same value type as the DTSTART of the event from which +;; this string came. I have however seen exceptions to that rule... +(define* (parse-recurrence-rule str optional: (datetime-parser parse-datetime)) (fold (lambda (kv o) (let* (((key val) kv)) (let-lazy ((symb (string->symbol val)) - (date (parse-datetime val)) + (date (datetime-parser val)) (days (map parse-day-spec (string-split val #\,))) (num (string->number val)) (nums (map string->number (string-split val #\,)))) + ;; TODO I think it's an error to give BYHOUR and under for dates which aren't datetimes (quick-case (string->symbol key) (UNTIL (set! (until o) date)) -- cgit v1.2.3