HTML small cal table now works with better intervals.

3 files changed, 37 insertions, 19 deletions

diff --git a/module/entry-points/html.scm b/module/entry-points/html.scm
index 6655d63a..ea1b2eeb 100644
--- a/module/entry-points/html.scm
+++ b/module/entry-points/html.scm
@@ -44,7 +44,7 @@
      (html-generate calendars events start end render-calendar)]
     [(wide)                             ; previously `chunked'
      (html-chunked-main count calendars events start (date month: 1))]
-    [(week)
+    [(week)                             ; TOOD handle week-start
      (html-chunked-main count calendars events start (date day: 7))]
     [(table)
      (html-table-main count calendars events start)]
diff --git a/module/output/html.scm b/module/output/html.scm
index b35a4d2f..2877a399 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -409,11 +409,30 @@
 ;; @end example
 ;; date - a date in the month to display
 ;; week-start - which day the week begins on, see (datetime util)
-(define (cal-table date week-start)
-  (define ((td attr) date)
-    `(td (@ ,attr)
-         (a (@ (href ,(date->string (set (day date) 1) "~Y-~m-~d")
-                     ".html#" ,(date->string date "~Y-~m-~d"))
+(define* (cal-table key:
+                    start-date
+                    end-date
+                    (week-start (week-start))
+                    next-start
+                    prev-start)
+  (define (td date)
+    `(td (@ (class
+              ,(when (date< date start-date) "prev ")
+              ,(when (date< end-date date) "next ")))
+         (a (@ (href ,(cond [(date< date start-date)
+                             ;; TODO find a prettier way to generate links to previous and next time intervals
+                             ;; TODO also, it would do good with a bit of testing for off-by-one errors
+                             (date->string
+                              (stream-find (lambda (d) (date<= d date (next-start d)))
+                                           (stream-iterate prev-start start-date))
+                              "~Y-~m-~d.html")]
+                            [(date< end-date date)
+                             (date->string
+                              (stream-find (lambda (d) (and (date<= d date)
+                                                       (date< date (next-start d))))
+                                           (stream-iterate next-start start-date))
+                              "~Y-~m-~d.html" )])
+                     "#" ,(date->string date "~Y-~m-~d"))
                (class "hidelink"))
             ,(day date))))
 
@@ -422,17 +441,12 @@
                             (weekday-list week-start))))
 
           ((tbody ,@(let* ((last current next
-                                 (month-days date week-start)))
-                      (define lst
-                        (append
-                         ;; ... 28 29 |
-                         (map (td '(class "prev")) last)
-                         ;; 1 2 ... 30 31
-                         (map (td '(class "cur")) current)
-                         ;; | 1 2 ...
-                         (map (td '(class "next")) next)))
-
-                      (tablify lst 7))))))
+                                 ;; A calendar table is always exactly one month, therefore
+                                 ;; it's safe to say that we are interested in the month which
+                                 ;; start-date is part of
+                                 (month-days (start-of-month start-date) week-start)))
+                      (tablify (map td (append last current next))
+                               7))))))
 
 
 
@@ -536,8 +550,10 @@
 
                             ;; calendar table
                             ;; TODO
-                            (div ,(cal-table (start-of-month start-date)
-                                             (week-start)))
+                            (div ,(cal-table start-date: start-date end-date: end-date
+                                             next-start: next-start
+                                             prev-start: prev-start
+                                             ))
 
                             ;; next button
                             ,(nav-link "»" (next-start start-date)))
diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm
index 61db98d6..3101bc85 100644
--- a/module/srfi/srfi-41/util.scm
+++ b/module/srfi/srfi-41/util.scm
@@ -48,6 +48,8 @@
         [else (filter-sorted-stream* pred? keep-remaining?
                                      (stream-cdr stream))]))
 
+;; Finds the first element in stream satisfying pred.
+;; Returns #f if nothing was found
 (define-public (stream-find pred stream)
   (cond ((stream-null? stream) #f)
         ((pred (stream-car stream)) (stream-car stream))