diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-22 18:33:32 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-22 18:33:32 +0200 |
commit | 6b600d3ee57f2b6ad4eda1e020d207cbfc1a817f (patch) | |
tree | c16eda62ecba1af2553a10a0816c137259a9e386 | |
parent | General cleanup. (diff) | |
download | calp-6b600d3ee57f2b6ad4eda1e020d207cbfc1a817f.tar.gz calp-6b600d3ee57f2b6ad4eda1e020d207cbfc1a817f.tar.xz |
Made multi day events appear in HTML.
Diffstat (limited to '')
-rw-r--r-- | module/html/html.scm | 10 | ||||
-rw-r--r-- | module/srfi/srfi-41/util.scm | 11 |
2 files changed, 19 insertions, 2 deletions
diff --git a/module/html/html.scm b/module/html/html.scm index d81faaaf..bb964963 100644 --- a/module/html/html.scm +++ b/module/html/html.scm @@ -18,9 +18,15 @@ (stream in-stream)) (if (stream-null? stream) stream-null - (let ((day (stream-car days))) + (let* ((day (stream-car days)) + (tomorow (add-day (date->time-utc (drop-time day))))) (let ((head (stream-take-while (ein? day) stream)) - (tail (stream-drop-while (ein? day) stream))) + (tail + (filter-sorted-stream* + (lambda (e) (time<? tomorow (attr e 'DTEND))) + (lambda (e) (time<=? tomorow (attr e 'DTSTART))) + stream))) + (stream-cons (cons day head) (loop (stream-cdr days) tail))))))) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 2492d088..56c50ce9 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -26,6 +26,17 @@ proc (stream-drop-while (negate proc) stream))) +(define-public (filter-sorted-stream* pred? keep-remaining? stream) + (cond [(stream-null? stream) stream-null] + [(keep-remaining? (stream-car stream)) stream] + [(pred? (stream-car stream)) + (stream-cons (stream-car stream) + (filter-sorted-stream* + pred? keep-remaining? + (stream-cdr stream)))] + [else (filter-sorted-stream* pred? keep-remaining? + (stream-cdr stream))])) + (define-public (stream-find pred stream) (cond ((stream-null? stream) #f) ((pred (stream-car stream)) (stream-car stream)) |