Basic support for events in small calendar.

4 files changed, 50 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
diff --git a/static/_small-calendar.scss b/static/_small-calendar.scss
index c4814285..6d5bb7ff 100644
--- a/static/_small-calendar.scss
+++ b/static/_small-calendar.scss
@@ -15,6 +15,9 @@
                smaller
            */
             padding: 5px;
+
+            /* TODO different styles for different calendars */
+            color: var(--color);
         }
     }
     > *:not(.column-head) {