Simplify (output html).

1 files changed, 61 insertions, 72 deletions

diff --git a/module/output/html.scm b/module/output/html.scm
index 86b684bc..d3a5b8be 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -1,25 +1,14 @@
 (define-module (output html)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-41)
-  #:use-module (srfi srfi-41 util)
-  #:use-module (vcomponent)
-  ;; #:use-module (vcomponent group)
-  #:use-module (vcomponent datetime)
   #:use-module (util)
-  #:use-module (util exceptions)
-  #:use-module (util config)
-  ;; #:use-module (util tree)
-  #:duplicates (last)
-  #:use-module (datetime)
-  ;; #:use-module (ice-9 curried-definitions)
-  #:use-module (ice-9 match)
-  #:use-module (text util)
-  #:use-module (vcomponent datetime output)
-
-  #:use-module (html components)
-  #:use-module (html util)
-  #:use-module (html vcomponent)
+
+  #:use-module ((srfi srfi-1) :select (last))
+  #:use-module ((srfi srfi-41) :select (stream-take stream-for-each))
+  #:use-module ((datetime)
+                :select (date-stream date
+                         remove-day month-days
+                         date+ date-
+                         month+ month-
+                         date->string))
   #:use-module ((html view calendar)
                 :select (html-generate))
 
@@ -29,6 +18,9 @@
   #:use-module ((html view calendar month)
                 :select (render-calendar-table))
 
+  #:use-module ((vcomponent instance methods)
+                :select (get-calendars get-event-set))
+
   #:autoload (vcomponent instance) (global-event-object)
   )
 
@@ -44,7 +36,14 @@
     (unless (file-exists? link)
       (symlink "../static" link))))
 
-(define-public (html-chunked-main count start-date chunk-length)
+
+(define (get-filename start-date)
+  (format #f "~a/html/~a.html"
+          (dirname (or (@ (global) basedir) "."))
+          (date->string start-date "~1")))
+
+
+(define (common count start-date chunk-length proc)
 
   (define calendars (get-calendars global-event-object))
   (define events (get-event-set global-event-object))
@@ -53,61 +52,51 @@
 
   (create-files)
 
-  ;; NOTE Something here isn't thread safe.
   (stream-for-each
-   (match-lambda
-     [(start-date end-date)
-      (let ((fname (format #f "~a/html/~a.html"
-                           (dirname (or (@ (global) basedir) "."))
-                           (date->string start-date "~1"))))
-        (format (current-error-port) "Writing to [~a]~%" fname)
-        (with-output-to-file fname
-          (lambda () (html-generate calendars: calendars
-                               events: events
-                               start-date: start-date
-                               end-date: end-date
-                               render-calendar: render-calendar
-                               next-start: (lambda (d) (date+ d chunk-length))
-                               prev-start: (lambda (d) (date- d chunk-length))
-                               ))))])
-   (let ((ms (stream-iterate (cut date+ <> chunk-length) start-date)))
-     (with-streams
-      (take count
-            (zip ms
-                 (map (cut date- <> (date day: 1)) ; last in month
-                      (cdr ms))))))))
+   (lambda (start-date)
+     (define fname (get-filename start-date))
+     (format (current-error-port) "Writing to [~a]~%" fname)
+     (with-output-to-file fname (lambda () (proc calendars events)) ))
+   (stream-take count (date-stream chunk-length start-date))
+   ))
+
 
+;; <int>, <date>, <date-duration> → xml string
+(define-public (html-chunked-main count start-date chunk-length)
 
+  (common count start-date chunk-length
+          (lambda (calendars events)
+            (html-generate calendars: calendars
+                           events: events
+                           start-date: start-date
+                           end-date: (remove-day (date+ start-date chunk-length))
+                           render-calendar: render-calendar
+                           next-start: (lambda (d) (date+ d chunk-length))
+                           prev-start: (lambda (d) (date- d chunk-length))
+                           ))))
 
-(define-public (html-table-main count start-date)
 
-  (define calendars (get-calendars global-event-object))
-  (define events (get-event-set global-event-object))
 
-  (create-files)
+(define-public (html-table-main count start-date)
 
-  (stream-for-each
-   (lambda (start-of-month)
-     (let ((fname (format #f "~a/html/~a.html"
-                          (dirname (or (@ (global) basedir) "."))
-                          (date->string start-of-month "~1"))))
-       (format (current-error-port) "Writing to [~a]~%" fname)
-       (let* ((before current after (month-days start-of-month (get-config 'week-start))))
-         (with-output-to-file fname
-           ;; TODO this produces incorrect next and prev links
-           ;; TODO It actually produces almost all date links wrong
-           (lambda () (html-generate calendars: calendars
-                                events: events
-                                ;; Appends for case where before or after is empty
-                                start-date: (car current)
-                                end-date: (date- (if (null? after)
-                                                     (last current)
-                                                     (car after))
-                                                 (date day: 1))
-                                render-calendar: render-calendar-table
-                                next-start: month+
-                                prev-start: month-
-                                pre-start: (car (append before current))
-                                post-end: (last (append current after))
-                                ))))))
-   (stream-take count (month-stream start-date))))
+  (common count start-date (date month: 1)
+          (let* ((before current after
+                         (month-days start-date)))
+
+            ;; TODO this produces incorrect next and prev links
+            ;; TODO It actually produces almost all date links wrong
+            (lambda (calendars events)
+              (html-generate calendars: calendars
+                             events: events
+                             ;; Appends for case where before or after is empty
+                             start-date: (car current)
+                             end-date: (date- (if (null? after)
+                                                  (last current)
+                                                  (car after))
+                                              (date day: 1))
+                             render-calendar: render-calendar-table
+                             next-start: month+
+                             prev-start: month-
+                             pre-start: (car (append before current))
+                             post-end: (last (append current after))
+                             )))))