Got rid of (output html).

2 files changed, 88 insertions, 126 deletions

diff --git a/module/entry-points/html.scm b/module/entry-points/html.scm
index e30dc7c1..de80f8d2 100644
--- a/module/entry-points/html.scm
+++ b/module/entry-points/html.scm
@@ -1,13 +1,26 @@
 (define-module (entry-points html)
   :export (main)
-  :use-module (output html)
   :use-module (util)
   :use-module (util time)
-  :use-module (util config)
   :use-module (util options)
-  ;; :use-module (vcomponent)
   :use-module (datetime)
   :use-module (ice-9 getopt-long)
+  :use-module ((ice-9 regex) :select (string-match regexp-substitute))
+
+  :use-module ((srfi srfi-41) :select (stream-take stream-for-each))
+  :use-module ((html view calendar) :select (html-generate))
+  :use-module ((html view calendar week)
+               :select (render-calendar)
+               :renamer (lambda _ 'render-calendar-wide))
+  :use-module ((html view calendar month)
+               :select (render-calendar-table))
+  :use-module ((vcomponent instance methods)
+                :select (get-calendars get-event-set))
+
+  :use-module ((sxml simple) :select (sxml->xml))
+  :use-module ((sxml transformations) :select (href-transformer))
+
+  :autoload (vcomponent instance) (global-event-object)
   )
 
 
@@ -39,6 +52,63 @@
 
     (help (single-char #\h) (description "Print this help."))))
 
+
+
+;; file existing but is of wrong type,
+(define (create-files)
+  (let* ((dir (dirname (or (@ (global) basedir) ".")))
+         (html (string-append dir "/html"))
+         (link (string-append html "/static")))
+    (unless (file-exists? html)
+      (mkdir html))
+    (unless (file-exists? link)
+      (symlink "../static" link))))
+
+
+(define (get-filename start-date)
+  (format #f "~a/html/~a.xml"
+          (dirname (or (@ (global) basedir) "."))
+          (date->string start-date "~1")))
+
+(define (re-root-static tree)
+  (href-transformer
+   tree
+   (lambda (str)
+     (aif (string-match "^/static" str)
+          (regexp-substitute #f it 'pre "static" 'post)
+          str))))
+
+(define (common count start-date chunk-length
+                render-calendar . extra-args)
+
+  (define calendars (get-calendars global-event-object))
+  (define events (get-event-set global-event-object))
+
+  ((@ (util time) report-time!) "html start")
+
+  (create-files)
+
+  (stream-for-each
+   (lambda (start-date)
+     (define fname (get-filename start-date))
+     (format (current-error-port) "Writing to [~a]~%" fname)
+     (with-output-to-file fname
+       (lambda () (sxml->xml (re-root-static
+                         (apply html-generate
+                                calendars: calendars
+                                events: events
+                                next-start: (lambda (d) (date+ d chunk-length))
+                                prev-start: (lambda (d) (date- d chunk-length))
+                                start-date: start-date
+                                end-date: (remove-day (date+ start-date chunk-length))
+                                render-calendar: render-calendar
+                                extra-args))))))
+   (stream-take count (date-stream chunk-length start-date))
+   ))
+
+
+
+
 (define (main args)
   (define opts (getopt-long args (getopt-opt opt-spec)))
   (define start (cond [(option-ref opts 'from #f) => parse-freeform-date]
@@ -52,18 +122,27 @@
     (throw 'return)
     )
 
+  ;; TODO a number of links are wrong, since they point to .html files,
+  ;; while we save the documents as .xml.
+
   (case style
-    [(wide)                             ; previously `chunked'
-     (html-chunked-main count start (date month: 1))]
+    [(wide)
+     (common count start (date month: 1) render-calendar-wide)]
+
     [(week)
+
      ;; TODO The small calendar is always centered on months, it might
      ;; be a good idea to instead center it on the current week, meaning
      ;; that the active row is always in the center
-     (html-chunked-main count
-                        (start-of-week start (get-config 'week-start))
-                        (date day: 7))]
+     (common count (start-of-week start)
+             (date day: 7)
+             render-calendar-wide)]
     [(table)
-     (html-table-main count start)]
+
+     (common count (start-of-month start) (date month: 1)
+             render-calendar-table
+             pre-start: (start-of-week start)
+             post-end: (end-of-week (end-of-month start)))]
     [else
      (error "Unknown html style: ~a" style)])
 
diff --git a/module/output/html.scm b/module/output/html.scm
index 16b4a060..e69de29b 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -1,117 +0,0 @@
-(define-module (output html)
-  #:use-module (util)
-
-  #: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
-                         date+ date-
-                         date->string
-                         start-of-week end-of-week
-                         end-of-month
-                         ))
-  #:use-module ((html view calendar)
-                :select (html-generate))
-
-  #:use-module ((html view calendar week)
-                :select (render-calendar))
-
-  #:use-module ((html view calendar month)
-                :select (render-calendar-table))
-
-  #:use-module ((vcomponent instance methods)
-                :select (get-calendars get-event-set))
-
-
-  #:use-module ((ice-9 regex) :select (string-match regexp-substitute))
-
-  #:use-module ((sxml simple) :select (sxml->xml))
-  #:use-module ((sxml transformations) :select (href-transformer))
-
-  #:autoload (vcomponent instance) (global-event-object)
-  )
-
-
-
-;; file existing but is of wrong type,
-(define (create-files)
-  (let* ((dir (dirname (or (@ (global) basedir) ".")))
-         (html (string-append dir "/html"))
-         (link (string-append html "/static")))
-    (unless (file-exists? html)
-      (mkdir html))
-    (unless (file-exists? link)
-      (symlink "../static" link))))
-
-
-(define (get-filename start-date)
-  (format #f "~a/html/~a.xml"
-          (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))
-
-  ((@ (util time) report-time!) "html start")
-
-  (create-files)
-
-  (stream-for-each
-   (lambda (start-date)
-     (define fname (get-filename start-date))
-     (format (current-error-port) "Writing to [~a]~%" fname)
-     (with-output-to-file fname
-       (lambda () (sxml->xml
-              (href-transformer
-               (proc calendars events)
-               (lambda (str)
-                 (aif (string-match "^/static" str)
-                      (regexp-substitute #f it 'pre "static" 'post)
-                      str)))))))
-   (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
-             ;; same
-             calendars: calendars
-             events: events
-             next-start: (lambda (d) (date+ d chunk-length))
-             prev-start: (lambda (d) (date- d chunk-length))
-             start-date: start-date
-             end-date: (remove-day (date+ start-date chunk-length))
-             render-calendar: render-calendar
-             ;; different
-             ))))
-
-;; start date MUST be the first in month
-(define-public (html-table-main count start-date)
-
-  (define chunk-length (date month: 1))
-  (define render-calendar render-calendar-table)
-
-  (common count start-date chunk-length
-          (lambda (calendars events)
-            (html-generate
-             ;; same
-             calendars: calendars
-             events: events
-             next-start: (lambda (d) (date+ d chunk-length))
-             prev-start: (lambda (d) (date- d chunk-length))
-             start-date: start-date
-             end-date: (remove-day (date+ start-date chunk-length))
-             render-calendar: render-calendar
-
-             ;; different
-             pre-start: (start-of-week start-date)
-             post-end: (end-of-week (end-of-month start-date))
-             ))))