From fa2d4807f7f0ba55d9798102a1471245c53766ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 14 Aug 2020 00:27:57 +0200 Subject: Simplify (output html). --- module/output/html.scm | 133 +++++++++++++++++++++++-------------------------- 1 file 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)) + )) + +;; , , → 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)) + ))))) -- cgit v1.2.3