diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/output/html.scm | 20 | ||||
-rw-r--r-- | module/vcomponent/datetime.scm | 86 | ||||
-rw-r--r-- | module/vcomponent/group.scm | 6 | ||||
-rw-r--r-- | module/vcomponent/parse/component.scm | 13 |
4 files changed, 71 insertions, 54 deletions
diff --git a/module/output/html.scm b/module/output/html.scm index 64859c2d..8ca831f0 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -97,10 +97,12 @@ [else ; guaranteed datetime (let ((s (attr ev 'DTSTART)) (e (attr ev 'DTEND))) - (let ((fmt-str (if (date= (get-date s) (get-date e)) - "~H:~M" "~Y-~m-~d ~H:~M"))) - (values (datetime->string s fmt-str) - (datetime->string e fmt-str))))])) + (if e + (let ((fmt-str (if (date= (get-date s) (get-date e)) + "~H:~M" "~Y-~m-~d ~H:~M"))) + (values (datetime->string s fmt-str) + (datetime->string e fmt-str))) + (datetime->string s "~Y-~m-~d ~H:~M")))])) @@ -241,7 +243,7 @@ ev `((class ,(when (date<? (as-date (attr ev 'DTSTART)) date) " continued") - ,(when (date<? date (as-date (attr ev 'DTEND))) + ,(when (and (attr ev 'DTEND) (date<? date (as-date (attr ev 'DTEND)))) " continuing")) (style ,style)))) @@ -282,7 +284,8 @@ ev `((class ,(when (date/-time< (attr ev 'DTSTART) start-date) " continued") - ,(when (date/-time< (date+ end-date (date day: 1)) (attr ev 'DTEND)) + ,(when (and (attr ev 'DTEND) + (date/-time< (date+ end-date (date day: 1)) (attr ev 'DTEND))) " continuing")) (style ,style)))) @@ -292,7 +295,8 @@ (define (lay-out-day day) (let* (((day-date . events) day) (time-obj (datetime date: day-date)) - (short-events (stream->list events))) + (zero-length-events short-events + (partition event-zero-length? (stream->list events)))) (fix-event-widths! short-events event-length-key: (lambda (e) (event-length/day day-date e))) @@ -301,6 +305,8 @@ ,@(map (lambda (time) `(div (@ (class "clock clock-" ,time)) "")) (iota 12 0 2)) + (div (@ (class "zero-width-events")) + ,(map make-block zero-length-events)) ,@(map (lambda (e) (create-block day-date e)) short-events)))) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 28d48361..057b9ca1 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -29,14 +29,20 @@ "Returns if the event overlaps the timespan. Event must have the DTSTART and DTEND attribute set." (timespan-overlaps? (attr event 'DTSTART) - (attr event 'DTEND) + (or (attr event 'DTEND) (attr event 'DTSTART)) begin end)) (define (overlapping? event-a event-b) (timespan-overlaps? (attr event-a 'DTSTART) - (attr event-a 'DTEND) + (or (attr event-a 'DTEND) + (if (date? (attr event-a 'DTSTART)) + (date+ (attr event-a 'DTSTART) (date day: 1)) + (attr event-a 'DTSTART))) (attr event-b 'DTSTART) - (attr event-b 'DTEND))) + (or (attr event-b 'DTEND) + (if (date? (attr event-b 'DTSTART)) + (date+ (attr event-b 'DTSTART) (date day: 1)) + (attr event-b 'DTSTART))))) (define (event-contains? ev date/-time) "Does event overlap the date that contains time." @@ -44,6 +50,10 @@ Event must have the DTSTART and DTEND attribute set." (end (add-day start))) (event-overlaps? ev start end))) +(define-public (event-zero-length? ev) + (and (datetime? (attr ev 'DTSTART)) + (not (attr ev 'DTEND)))) + (define-public (ev-time<? a b) (date/-time<? (attr a 'DTSTART) (attr b 'DTSTART))) @@ -51,42 +61,49 @@ Event must have the DTSTART and DTEND attribute set." ;; Returns length of the event @var{e}, as a time-duration object. (define-public (event-length e) (if (not (attr e 'DTEND)) - (datetime date: - (if (date? (attr e 'DTSTART)) - #24:00:00 - #01:00:00)) + (if (date? (attr e 'DTSTART)) + (date day: 1) + (datetime)) ((if (date? (attr e 'DTSTART)) date-difference datetime-difference) (attr e 'DTEND) (attr e 'DTSTART)))) (define-public (event-length/clamped start-date end-date e) - (if (date? (attr e 'DTSTART)) - (date-difference (date-min (date+ end-date (date day: 1)) - (attr e 'DTEND)) - (date-max start-date - (attr e 'DTSTART))) - (datetime-difference (datetime-min (datetime date: (date+ end-date (date day: 1))) - (attr e 'DTEND)) - (datetime-max (datetime date: start-date) - (attr e 'DTSTART))))) + (let ((end (or (attr e 'DTEND) + (if (date? (attr e 'DTSTART)) + (date+ (attr e 'DTSTART) (date day: 1)) + (attr e 'DTSTART))))) + (if (date? (attr e 'DTSTART)) + (date-difference (date-min (date+ end-date (date day: 1)) + end) + (date-max start-date + (attr e 'DTSTART))) + (datetime-difference (datetime-min (datetime date: (date+ end-date (date day: 1))) + end) + (datetime-max (datetime date: start-date) + (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}. ;; 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 date e) - (let ((start (attr e 'DTSTART)) - (end (attr e 'DTEND))) - (cond [(date= date (as-date start) (as-date end)) - (time- (as-time end) (as-time start))] - ;; Starts today, end in future day - [(date= date (as-date start)) - (time- #24:00:00 (as-time start))] - ;; Ends today, start earlier day - [(date= date (as-date end)) - (as-time end)] - ;; start earlier date, end later date - [else #24:00:00]))) + (if (not (attr e 'DTEND)) + (if (date? (attr e 'DTSTART)) + #24:00:00 + (time)) + (let ((start (attr e 'DTSTART)) + (end (attr e 'DTEND))) + (cond [(date= date (as-date start) (as-date end)) + (time- (as-time end) (as-time start))] + ;; Starts today, end in future day + [(date= date (as-date start)) + (time- #24:00:00 (as-time start))] + ;; Ends today, start earlier day + [(date= date (as-date end)) + (as-time end)] + ;; start earlier date, end later date + [else #24:00:00])))) ;; 22:00 - 03:00 @@ -98,10 +115,12 @@ Event must have the DTSTART and DTEND attribute set." ;; For practical purposes, an event being long means that it shouldn't be rendered as a part ;; of a regular day. (define-public (long-event? ev) - (or (date? (attr ev 'DTSTART)) - (datetime<= (datetime date: (date day: 1)) - (datetime-difference (attr ev 'DTEND) - (attr ev 'DTSTART))))) + (if (date? (attr ev 'DTSTART)) + #t + (aif (attr ev 'DTEND) + (datetime<= (datetime date: (date day: 1)) + (datetime-difference it (attr ev 'DTSTART))) + #f))) ;; DTEND of the last instance of this event. @@ -121,7 +140,8 @@ Event must have the DTSTART and DTEND attribute set." (define-public (events-between start-date end-date events) (define (overlaps e) (timespan-overlaps? start-date (date+ end-date (date day: 1)) - (attr e 'DTSTART) (attr e 'DTEND))) + (attr e 'DTSTART) (or (attr e 'DTEND) + (attr e 'DTSTART)))) ((@ (srfi srfi-41) stream-filter) overlaps diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm index 1e5728c6..72acbce9 100644 --- a/module/vcomponent/group.scm +++ b/module/vcomponent/group.scm @@ -26,7 +26,11 @@ ;; of tommorow, and finishes with the rest when it finds the first ;; object which begins tomorow (after midnight, exclusize). (filter-sorted-stream* - (lambda (e) (date/-time<? tomorow (attr e 'DTEND))) + (lambda (e) (date/-time<? tomorow + (or (attr e 'DTEND) + (if (date? (attr e 'DTSTART)) + (date+ (attr e 'DTSTART) (date day: 1)) + (attr e 'DTSTART))))) (lambda (e) (date/-time<=? tomorow (attr e 'DTSTART))) stream))) diff --git a/module/vcomponent/parse/component.scm b/module/vcomponent/parse/component.scm index c2d297fd..ea695696 100644 --- a/module/vcomponent/parse/component.scm +++ b/module/vcomponent/parse/component.scm @@ -109,20 +109,7 @@ (loop (cdr lst) (cons (make-vcomponent (string->symbol (cadr head))) stack))] [(string=? "END" (car head)) - ;; TODO This is an ugly hack until the rest of the code is updated - ;; to work on events without an explicit DTEND attribute. (when (eq? (type (car stack)) 'VEVENT) - (when (not (attr (car stack) 'DTEND)) - (set! (attr (car stack) 'DTEND) - (let ((start (attr (car stack) 'DTSTART))) - ;; p. 54, 3.6.1 - ;; If DTSTART is a date then it's an all - ;; day event. If DTSTART instead is a - ;; datetime then the event has a length - ;; of 0? - (if (date? start) - (date+ start (date day: 1)) - (datetime+ start (datetime time: (time hour: 1))))))) ;; This isn't part of the field values since we "need" ;; the type of DTSTART for UNTIL to work. |