From eee8de70127f1fdfc07f30bf7537897c2ae0b142 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 9 Nov 2019 19:16:16 +0100
Subject: Work on HTML output.

---
 module/output/html.scm       | 62 ++++++++++++++++++++++++++++++++++++--------
 module/srfi/srfi-19/util.scm | 25 ++++++++++++++----
 2 files changed, 71 insertions(+), 16 deletions(-)

(limited to 'module')

diff --git a/module/output/html.scm b/module/output/html.scm
index adbea85e..b3adefd6 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -121,9 +121,6 @@
             (rel "stylesheet")
             (href ,path))))
 
-(define opt-spec
-  '((from (value #t) (single-char #\f))
-    (to (value #t) (single-char #\t))))
 
 (define (fmt-time-span ev)
   (let* ((fmt (if (time<? (time-difference (attr ev 'DTEND) (attr ev 'DTSTART))
@@ -189,7 +186,15 @@
 ;; 29 30
 ;; @end example
 (define (cal-table date today)
-  (let ((td (lambda (p) (lambda (d) `(td (@ ,p) ,d)))))
+  #;(define (pad0 d) (when (< d 10) (format #f h0)))
+  (define (pad0 d) (format #f "~2,'0d" d))
+  (define last-month-date (normalize-date* (set (date-month date) = (- 1))))
+  (define next-month-date (normalize-date* (set (date-month date) = (+ 1))))
+  (let ((td (lambda (attr other-date) (lambda (d) `(td (@ ,attr) (a (@ (href ,(date->string other-date "~Y-~m-~d")
+                                                                   ".html#" ,(date->string other-date "~Y-~m-")
+                                                                   ,(pad0 d))
+                                                             (class "hidelink")) ,d))))))
+
     `(table (@ (class "small-calendar"))
             (thead (tr ,@(map (lambda (d) `(td ,d)) '(MÅ TI ON TO FR LÖ SÖ))))
             (tbody ,@(let recur
@@ -197,16 +202,17 @@
                                       (month-len (days-in-month month))
                                       (prev-month-len (days-in-month (previous-month month)))
                                       (month-start (week-day date)))
-                                 (append (map (td '(class "prev"))
+                                 (append (map (td '(class "prev") last-month-date)
                                               (iota month-start (- prev-month-len month-start)))
                                          (map (lambda (p) `(td (@ ,@(assq-merge '((class " cur ")) (cdar p)))
                                                           ,@(cdr p)))
+                                              ;; TODO only today in current month
                                               (map (lambda (d) `((@ (class ,(when (= d (date-day today)) "today")))
                                                             (a (@ (href "#" ,(date->string date "~Y-~m-")
-                                                                        ,(when (< d 10) 0) ,d)
+                                                                        ,(pad0 d))
                                                                   (class "hidelink")) ,d)))
                                                    (iota month-len 1)))
-                                         (map (td '(class "next"))
+                                         (map (td '(class "next") next-month-date)
                                               (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))))
                        (unless (null? lst)
                          (let* ((w rest (split-at lst 7)))
@@ -259,14 +265,48 @@
                             `(span "Version " (a (@ (href ,url)) ,hash)))))
                 (aside (@ (class "sideinfo"))
                        (div (@ (class "about"))
+                            (div (@ (class "nav"))
+                                 (a (@ (href "#")) "«"))
                             (div ,(cal-table (start-of-month start)
-                                             (current-date))))
+                                             (current-date)))
+                            (div (@ (class "nav"))
+                                 (a (@ (href "#")) "»")))
                        (div (@ (class "eventlist"))
                             ,@(stream->list (stream-map fmt-day evs)))))))))
 
+(define opt-spec
+  '((from (value #t) (single-char #\f))
+    (to (value #t) (single-char #\t))
+    (chunked)
+    )
+  )
+
 (define-public (html-main calendars events args)
   (define opts (getopt-long args opt-spec))
-  (define start (parse-freeform-date (option-ref opts 'from "2019-04-15")))
-  (define end   (parse-freeform-date (option-ref opts 'to   "2019-05-10")))
 
-  (html-generate calendars events start end))
+  (cond [(option-ref opts 'chunked #f)
+         (let* ((start (cond [(option-ref opts 'from #f) => parse-freeform-date]
+                             [else (start-of-month (current-date))])))
+
+           (stream-for-each (lambda (pair)
+                              (format (current-error-port) "d = ~a~%u = ~a~%" (car pair) (cadr pair))
+                              (let ((fname (format #f "./html/~a.html" (date->string (car pair) "~1"))))
+                                (format (current-error-port) "Writing to [~a]~%" fname)
+                                (with-output-to-file fname
+                                  (lambda () (apply html-generate calendars events pair)))))
+                            (let ((ms (month-stream start)))
+                              (stream-take
+                               12 (stream-zip
+                                   ms (stream-map (lambda (d) (normalize-date**
+                                                          (set (date-day d) = (- 1))))
+                                                  (stream-cdr ms))))
+                              )))
+
+
+         ]
+        [else
+         (let* ((start (cond [(option-ref opts 'from #f) => parse-freeform-date]
+                            [else (start-of-month (current-date))]))
+                (end (cond [(option-ref opts 'to  #f) => parse-freeform-date]
+                           [else (normalize-date* (set (date-month start) = (+ 1)))])))
+           (html-generate calendars events start end))]))
diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm
index 67d407f8..e4439da5 100644
--- a/module/srfi/srfi-19/util.scm
+++ b/module/srfi/srfi-19/util.scm
@@ -98,7 +98,6 @@ attribute set to 0. Can also be seen as \"Start of day\""
         (time<? s1-end s2-end))))
 
 (define-public (normalize-date date)
-
   (time-utc->date (date->time-utc date)
                   (zone-offset date)))
 
@@ -113,14 +112,30 @@ attribute set to 0. Can also be seen as \"Start of day\""
                    (make-time time-duration 0 10))))
   (set (date-second next-date) 0))
 
-;; Returns a stream of date objects, one day appart, staring from start-day.
-(define-public (day-stream start-day)
+(define-public (normalize-date** date)
+  (define next-date
+    (time-utc->date
+     (subtract-duration (date->time-utc date)
+                        (make-time time-duration 0 7200))))
+  (set (date-second next-date) 0))
+
+;; date x (date → date) → stream<date>
+(define (date-increment-stream start-date transfer-proc)
   (stream-iterate
    (lambda (d)
      (drop-time
       (normalize-date*
-       (set (date-day d) = (+ 1)))))
-   (drop-time start-day)))
+       ;; NOTE Adds one hour to compensate for summer -> winter time transition
+       ;; TODO figure out better way to do this.
+       (set (date-hour (transfer-proc d)) = (+ 1)))))
+   (drop-time start-date)))
+
+;; Returns a stream of date objects, one day appart, staring from start-day.
+(define-public (day-stream start-day)
+  (date-increment-stream start-day (lambda (d) (set (date-day d) = (+ 1)))))
+
+(define-public (month-stream start-date)
+  (date-increment-stream start-date (lambda (d) (set (date-month d) = (+ 1)))))
 
 (define-public (in-date-range? start-date end-date)
   (lambda (date)
-- 
cgit v1.2.3