From 6e65bf675a5449b09f418d8ec713e9f3a6b1f21c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 14 Aug 2020 01:11:39 +0200 Subject: Got rid of (output html). --- module/entry-points/html.scm | 97 +++++++++++++++++++++++++++++++---- module/output/html.scm | 117 ------------------------------------------- 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)) - )) - - -;; , , → 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)) - )))) -- cgit v1.2.3