Work on small-calendar.

2 files changed, 90 insertions, 63 deletions

diff --git a/module/html/caltable.scm b/module/html/caltable.scm
new file mode 100644
index 00000000..fb2cbe02
--- /dev/null
+++ b/module/html/caltable.scm
@@ -0,0 +1,89 @@
+(define-module (html caltable)
+  :use-module (util)
+  :use-module (html util)
+  :use-module (datetime)
+  :use-module (srfi srfi-41)
+  )
+
+;; Small calendar similar to the one below.
+;; TODO highlight days depending on which events they contain
+;; TODO run this standalone, for embedding in other websites.
+;; @example
+;; må ti on to fr lö sö
+;;  1  2  3  4  5  6  7
+;;  8  9 10 11 12 13 14
+;; 15 16 17 18 19 20 21
+;; 22 23 24 25 26 27 28
+;; 29 30
+;; @end example
+;; 
+;; start-date : <date>
+;; 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 (->link date)
+    (date->string date "~Y-~m-~d.html"))
+
+  ;; (<date> → sxml-attributes) → <date> → sxml
+  (define (td attr)
+    (lambda (date)
+      `(a (@ ,@(attr date))
+          ;; NOTE This time object is the correct place to show the existance
+          ;; 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")))
+                ,(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))
+
+  `(div (@ (class "small-calendar"))
+
+        ;; Cell 0, 0. The letter v. for week number
+        (div (@ (class "column-head row-head")) "v.")
+
+        ;; top row, names of week days
+        ,@(map (lambda (d) `(div (@ (class "column-head"))
+                            ,(string-titlecase (week-day-name d 2))))
+               (weekday-list))
+
+        ;; left columun, week numbers
+        ,@(map (lambda (v) `(div (@ (class "row-head")) ,v))
+               (map week-number
+                    (stream->list
+                     (stream-take-while (lambda (s) (date<= s post-end))
+                                        (week-stream pre-start)))))
+
+        ;; actual days
+
+        ,@(map (td (lambda (date)
+                     `((class "prev")
+                       (href ,(->link
+                               ;; (prev-start date)
+                               (iterate
+                                prev-start
+                                (lambda (d) (date<= d date (next-start d)))
+                                start-date))
+                             "#" ,(date-link date)))))
+               (date-range pre-start (remove-day start-date)))
+
+
+        ,@(map (td (lambda (date) `((href "#" ,(date-link date)))))
+               (date-range start-date end-date))
+
+
+        ,@(map (td (lambda (date)
+                     `((class "next")
+                       (href ,(->link
+                               ;; (next-start date)
+                               (iterate
+                                next-start
+                                (lambda (d) (and (date<= d date)
+                                            (date< date (next-start d))))
+                                start-date)) "#" ,(date-link date)))))
+               (date-range (add-day end-date) post-end))))
diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm
index db0debda..ac5bf77a 100644
--- a/module/html/view/calendar.scm
+++ b/module/html/view/calendar.scm
@@ -16,6 +16,7 @@
                                           ))
   :use-module (html config)
   :use-module (html util)
+  :use-module ((html caltable) :select (cal-table))
 
   :use-module (util config)
 
@@ -31,69 +32,6 @@
   )
 
 
-;; Small calendar similar to the one below.
-;; TODO highlight days depending on which events they contain
-;; TODO run this standalone, for embedding in other websites.
-;; @example
-;; må ti on to fr lö sö
-;;  1  2  3  4  5  6  7
-;;  8  9 10 11 12 13 14
-;; 15 16 17 18 19 20 21
-;; 22 23 24 25 26 27 28
-;; 29 30
-;; @end example
-;; date - The start date of the month to display
-(define* (cal-table key: start-date end-date next-start prev-start)
-
-  (define (td date)
-    `(a (@ ,@(cond
-              ;; We are before our time interval
-              [(date< date start-date)
-               ;; TODO find a prettier way to generate links to previous and next time intervals
-               `((class "prev")
-                 (href ,(date->string
-                         (stream-find (lambda (d) (date<= d date (next-start d)))
-                                      (stream-iterate prev-start start-date))
-                         "~Y-~m-~d.html")
-                       "#" ,(date-link date)))]
-              ;; We are after our time interval
-              [(date< end-date date)
-               `((class "next")
-                 (href ,(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-link date)))]
-              ;; We are in our time interval
-              [else `((href "#" ,(date-link date)))]))
-        ;; NOTE This time object is the correct place to show the existance
-        ;; 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"))) ,(day date))))
-
-  (let* ((last-months current next
-                      (month-days (start-of-month start-date)))
-         (events (append last-months current next)))
-    `(div (@ (class "small-calendar"))
-          (div (@ (class "column-head row-head")) "v.")
-          ,@(map (lambda (d) `(div (@ (class "column-head"))
-                              ,(string-titlecase (week-day-name d 2))))
-                 (weekday-list))
-          ,@(let ((first (start-of-week (car events)))
-                  (last (start-of-week (last events))))
-              (map (lambda (v) `(div (@ (class "row-head")) ,v))
-                   (map (lambda (d) (week-number d))
-                        (stream->list
-                         (stream-take-while (lambda (s) (date<= s last))
-                                            (week-stream first))))))
-          ,@(map td events
-                 ))))
-
-
-
-
 ;;; Main-stuff