diff options
| -rw-r--r-- | module/output/html.scm | 11 | ||||
| -rw-r--r-- | module/vcomponent/datetime.scm | 22 | ||||
| -rw-r--r-- | tests/srfi-19-alt-compare.scm | 2 |
3 files changed, 26 insertions, 9 deletions
diff --git a/module/output/html.scm b/module/output/html.scm index 4bb12b45..f30e6338 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -39,7 +39,7 @@ ;; Takes a list of vcomponents, sets their widths and x-positions to optimally ;; fill out the space, without any overlaps. -(define (fix-event-widths! start-of-day lst) +(define (fix-event-widths! date lst) ;; The tree construction is greedy. This means ;; that if a smaller event preceeds a longer ;; event it would capture the longer event to @@ -49,7 +49,8 @@ ;; @var{x} is how for left in the container we are. (let inner ((x 0) (tree (make-tree overlapping? - (sort* lst time>? (lambda (e) (event-length/day e)))))) + (sort* lst time>? + (lambda (e) (event-length/day date e)))))) (unless (null? tree) (let ((w (/ (- 1 x) (+ 1 (length-of-longst-branch (left-subtree tree)))))) @@ -89,7 +90,7 @@ 0) ;; height - (* 100/24 (time->decimal-hour (event-length/day ev))))) + (* 100/24 (time->decimal-hour (event-length/day date ev))))) `(a (@ (href "#" ,(UID ev)) (class "hidelink")) @@ -126,8 +127,8 @@ (format (current-error-port) "long=~a, short=~a~%" (length long-events) (length short-events)) - (fix-event-widths! time-obj short-events) - (fix-event-widths! time-obj long-events) + (fix-event-widths! date short-events) + (fix-event-widths! date long-events) `(div (@ (class "day")) (div (@ (class "meta")) ,(let ((str (date-link date))) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 765c065d..016eeaac 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -54,10 +54,24 @@ Event must have the DTSTART and DTEND attribute set." ;; 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 e) - (time- - (time-min #00:00:00 (as-time (attr e 'DTEND))) - (time-max #24:00:00 (as-time (attr e 'DTSTART))))) +(define-public (event-length/day date e) + ;; TODO date= > 2 elements + (cond [(and (date= (as-date (attr e 'DTSTART)) + (as-date (attr e 'DTEND))) + (date= (as-date (attr e 'DTSTART)) + date)) + (time- (as-time (attr e 'DTEND)) + (as-time (attr e 'DTSTART)))] + ;; Starts today, end in future day + [(date= (as-date (attr e 'DTSTART)) + date) + (time- #24:00:00 (as-time (attr e 'DTSTART)))] + ;; Ends today, start earlier day + [(date= (as-date (attr e 'DTEND)) + date) + (as-time (attr e 'DTEND))] + ;; start earlier date, end later date + [else #24:00:00])) ;; 22:00 - 03:00 diff --git a/tests/srfi-19-alt-compare.scm b/tests/srfi-19-alt-compare.scm index 7cf99bcd..5ee7e63d 100644 --- a/tests/srfi-19-alt-compare.scm +++ b/tests/srfi-19-alt-compare.scm @@ -63,3 +63,5 @@ (test-assert "date/-time< other dt, same date" (date/-time< #2020-01-01 #2020-01-01T10:00:00)) + +(test-assert (not (date/-time< #2018-11-30T08:10:00 #2014-04-13T16:00:00))) |