diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-23 23:12:30 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-29 15:14:46 +0200 |
commit | 4d0b44375f1e869f6fa69dc09f029e9bf7574c1d (patch) | |
tree | 1ef2214a2a1882c0399c9c23b7560aa27d651965 /module/calp | |
parent | Minor fixes to 'html --help'. (diff) | |
download | calp-4d0b44375f1e869f6fa69dc09f029e9bf7574c1d.tar.gz calp-4d0b44375f1e869f6fa69dc09f029e9bf7574c1d.tar.xz |
Basic support for events in small calendar.
Diffstat (limited to 'module/calp')
-rw-r--r-- | module/calp/html/caltable.scm | 37 | ||||
-rw-r--r-- | module/calp/html/view/calendar.scm | 10 | ||||
-rw-r--r-- | module/calp/html/view/small-calendar.scm | 6 |
3 files changed, 47 insertions, 6 deletions
diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm index 2f5a6d31..bb642959 100644 --- a/module/calp/html/caltable.scm +++ b/module/calp/html/caltable.scm @@ -3,6 +3,9 @@ :use-module (calp html util) :use-module (datetime) :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (vcomponent) + :use-module ((vcomponent datetime) :select (events-between)) ) ;; Small calendar similar to the one below. @@ -21,7 +24,17 @@ ;; end-date : <date> ;; next-start : <date> → <date> ;; prev-start : <date> → <date> -(define*-public (cal-table key: start-date end-date next-start prev-start) +(define*-public (cal-table key: start-date end-date next-start prev-start + (event-stream stream-null)) + + (define month-start (start-of-month start-date)) + (define pre-start (start-of-week month-start)) + (define month-end (end-of-month start-date)) + (define post-end (end-of-week month-end)) + + (define events + (events-between pre-start post-end event-stream)) + (define (->link date) (date->string date "~Y-~m-~d.html")) @@ -34,13 +47,25 @@ ;; of an event on a given day in this small calendar. For example ;; making the text red for all holidays, or creating a yellow background ;; for events from a specific source. - (time (@ (datetime ,(date->string date "~Y-~m-~d"))) + (time (@ (class + ,(string-join + (stream->list + (stream-map + (lambda (e) (string-append + "CAL_" (html-attr (prop (parent e) 'NAME)))) + ;; TODO this overshoots, making sunday 00:00 events also + ;; part of saturday. + (events-between + date (add-day date) + events))) + " " 'infix)) + (datetime ,(date->string date "~Y-~m-~d"))) ,(day date))))) - (define month-start (start-of-month start-date)) - (define pre-start (start-of-week month-start)) - (define month-end (end-of-month start-date)) - (define post-end (end-of-week month-end)) + (format (current-error-port) "~a events between ~a and ~a~%" + (stream-length events) + (date->string pre-start) + (date->string post-end)) `(div (@ (class "small-calendar")) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index a505b586..f908119e 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -187,6 +187,16 @@ (div ,(cal-table start-date: start-date end-date: end-date next-start: next-start prev-start: prev-start + event-stream: + ;; TODO propper lookup + (list->stream + (sort* + (children + (find (lambda (c) + (string=? "[alma/]" (prop c 'NAME))) + calendars)) + date/-time< + (extract 'DTSTART))) )) ;; next button diff --git a/module/calp/html/view/small-calendar.scm b/module/calp/html/view/small-calendar.scm index 80cbbaf2..78c7e30f 100644 --- a/module/calp/html/view/small-calendar.scm +++ b/module/calp/html/view/small-calendar.scm @@ -2,6 +2,10 @@ :use-module ((calp html components) :select (xhtml-doc include-css)) :use-module ((calp html caltable) :select (cal-table)) :use-module ((datetime) :select (month- month+ remove-day date->string)) + + + :use-module ((vcomponent instance methods) :select (get-event-set)) + :use-module ((vcomponent instance) :select (global-event-object)) ) (define-public (render-small-calendar month standalone) @@ -10,6 +14,8 @@ end-date: (remove-day (month+ month)) next-start: month+ prev-start: month- + ;; TODO proper subset + event-stream: (get-event-set global-event-object) )) (if standalone (xhtml-doc |