Add relevant content to calendar table.

1 files changed, 33 insertions, 9 deletions

diff --git a/module/output/html.scm b/module/output/html.scm
index 5380d354..54ac7538 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -285,20 +285,44 @@
        (div (@ (class "days"))
             ,@(stream->list (stream-map lay-out-day event-groups)))))
 
-;; TODO this currently only popuplates the table with the number of events for
-;;      each day. It should show all the actual events.
+(define (make-small-block event)
+  `(a (@ (href "#" ,(UID event))
+         (class "hidelink"))
+      (div (@ (class "inline-event CAL_"
+                ,(html-attr (attr (parent event) 'NAME))))
+           ,((summary-filter) event (attr event 'SUMMARY)))))
+
 ;; (stream event-group) -> sxml
 (define (render-calendar-table event-groups)
   `(div (@ (class "caltable"))
         ,@(map (lambda (d) `(div (@ (class "thead")) ,(week-day-name d)))
                (weekday-list (week-start)))
-        ,@(stream->list
-           (stream-map
-            (match-lambda
-              [(day-date . events)
-               `(div (@ (class "tbody"))
-                     ,(stream-length events))])
-            event-groups))))
+        ,@(cons
+           ;; First day is a special case, since I always want to show a full date there.
+           ;; For all other days I'm only interested in the parts that change.
+           (let* (((day-date . events) (stream-car event-groups)))
+             `(div (@ (class "tbody")) "")
+             `(div (@ (class "tbody"))
+                   (div (@ (class "date-info"))
+                        (span (@ (class "day-number")) ,(date->string day-date "~e"))
+                        (span (@ (class "month-name")) ,(date->string day-date "~b"))
+                        (span (@ (class "year-number")) ", ",(date->string day-date "~Y")))
+                   ,@(stream->list (stream-map make-small-block events))))
+           (stream->list
+            (stream-map
+             (match-lambda
+               [(day-date . events)
+                `(div (@ (class "tbody"))
+                      (div (@ (class "date-info"))
+                           (span (@ (class "day-number")) ,(date->string day-date "~e"))
+                           ,(when (= 1 (day day-date))
+                              `(span (@ (class "month-name")) ,(date->string day-date "~b")))
+                           ,(when (= 1 (month day-date) (day day-date))
+                              `(span (@ (class "year-number"))
+                                     ", " ,(date->string day-date "~Y"))))
+                      ,@(stream->list
+                         (stream-map make-small-block events)))])
+             (stream-cdr event-groups))))))
 
 
 ;;; NOTE