From e622337c3abab51c0a10dc7f60ff93e3ad0cd9f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 22 Mar 2020 19:30:27 +0100 Subject: Begin changing how html calls work. --- module/output/html.scm | 142 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 100 insertions(+), 42 deletions(-) (limited to 'module/output') diff --git a/module/output/html.scm b/module/output/html.scm index 8e46aa87..fa9d4f47 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -1,4 +1,4 @@ -(define-module (output html) + (define-module (output html) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-41) @@ -234,24 +234,11 @@ ,@(map (lambda (e) (create-block day-date e)) short-events))))) -(define (lay-out-long-events event-groups) - - (define start (car (stream-car event-groups))) - (define end (car (stream-car (stream-reverse event-groups)))) - - (stream-map - (match-lambda - [(d . events) - (let* ((long-events _ (partition long-event? (stream->list events)))) - (let ((long-events - (filter (lambda (e) (date= d (as-date (attr e 'DTSTART)))) - long-events))) - (fix-event-widths! long-events event-length-key: event-length - event-length-comperator: >) - (map (lambda (e) (create-top-block start end e)) - long-events) - ))]) - event-groups)) +(define (lay-out-long-events start end events) + (fix-event-widths! events event-length-key: event-length + event-length-comperator: >) + (map (lambda (e) (create-top-block start end e)) + events)) (define (time-marker-div) ;; element to make rest of grid align correct. @@ -264,17 +251,48 @@ ,time ":00"))) (iota 12 0 2))))) -(define-public (render-calendar event-groups) - `(div (@ (class "calendar")) - (div (@ (class "days")) - ,@(time-marker-div) - (div (@ (class "longevents") - (style "grid-column-end: span " ,(stream-length event-groups))) - "" ; prevent self-closing - ,@(stream->list (lay-out-long-events event-groups))) - ,@(concatenate (stream->list (stream-map lay-out-day event-groups)))))) +;; date, date, [sorted-stream events] → [list events] +;;; TODO +(define (events-between start-date end-date events) + (filter-sorted-stream + (lambda (e) + (timespan-overlaps? start-date end-date + (attr e 'DTSTART) (attr e 'DTEND))) + events)) - +;; Returns number of days in time interval. +;; @example +;; (days-between #2020-01-01 #2020-01-05) +;; ⇒ 5 +;; @end example +;; date, date → int +(define (days-between start-date end-date) + ;; TODO do rounding better + (inexact->exact (ceiling (1+ (exact->inexact (/ (date-difference end-date start-date) + 86400)))))) + +;; date, date → [list date] +(define (date-range start end) + (stream->list + (stream-take-while (lambda (d) (date<= d end)) + (day-stream start)))) + +(define*-public (render-calendar key: events start-date end-date #:allow-other-keys) + (let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events))))) + `(div (@ (class "calendar")) + (div (@ (class "days")) + ,@(time-marker-div) + (div (@ (class "longevents") + (style "grid-column-end: span " ,(days-between start-date end-date))) + "" ; prevent self-closing + ,@(lay-out-long-events start-date end-date long-events)) + ,@(let* ((r (date-range start-date end-date)) + (event-groups (get-groups-between (group-stream (list->stream short-events)) + start-date end-date))) + (concatenate (stream->list (stream-map lay-out-day event-groups)) + )))))) + + ;;; Prodcedures for text output ;; For sidebar, just text @@ -324,7 +342,11 @@ ,((summary-filter) event (attr event 'SUMMARY))))) ;; (stream event-group) -> sxml -(define (render-calendar-table event-groups) +(define* (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys) + + (define event-groups (get-groups-between (group-stream events) + pre-start post-end)) + `(div (@ (class "caltable")) ,@(map (lambda (d) `(div (@ (class "thead")) ,(week-day-name d))) (weekday-list (week-start))) @@ -343,7 +365,11 @@ (match-lambda [(day-date . events) `(div (@ (class "cal-cell")) - (div (@ (class "date-info")) + (div (@ (class "date-info " + ,(when (or (date< day-date start-date) + (date< end-date day-date)) + "non-current") + )) (span (@ (class "day-number")) ,(date->string day-date "~e")) ,(when (= 1 (day day-date)) `(span (@ (class "month-name")) ,(date->string day-date "~b"))) @@ -420,7 +446,6 @@ (define repo-url (make-parameter "https://git.hornquist.se")) - ;;; calendars ;;; events ;;; grouped events @@ -429,11 +454,17 @@ ;;; end-date ;;; post-end-date ;;; render-procedure -(define-public (html-generate calendars events start-date end-date render-calendar) +(define*-public (html-generate calendars events start-date end-date render-calendar + key: + next-start ; date → date + prev-start ; date → date + (pre-start start-date) + (post-end end-date)) ;; TODO maybe don't do this again for every month - (define evs (get-groups-between (group-stream events) - start-date end-date)) + ;; (define evs (get-groups-between (group-stream events) + ;; start-date end-date)) + (define month-base (start-of-month start-date)) (define (nav-link display date) `(a (@ (href ,(date->string date "~Y-~m-~d") ".html") @@ -441,6 +472,12 @@ (div (@ (class "nav")) ,display))) + (unless next-start + (error 'html-generate "Next-start needs to be a procedure")) + + (unless prev-start + (error 'html-generate "Prev-start needs to be a procedure")) + (display "\n") ((@ (sxml simple) sxml->xml) `(html (@ (lang sv)) @@ -471,7 +508,15 @@ (div (@ (class "root")) (main ;; Actuall calendar - ,(render-calendar evs) + ,(render-calendar calendars: calendars + events: events + start-date: start-date + end-date: end-date + pre-start: pre-start + post-end: post-end + next-start: next-start + prev-start: prev-start + ) ;; Page footer (footer (span "Page generated " ,(date->string (current-date))) @@ -487,14 +532,15 @@ ;; Small calendar and navigation (div (@ (class "about")) ;; prev button - ,(nav-link "«" (month- start-date)) + ,(nav-link "«" (prev-start start-date)) ;; calendar table + ;; TODO (div ,(cal-table (start-of-month start-date) (week-start))) ;; next button - ,(nav-link "»" (month+ start-date))) + ,(nav-link "»" (next-start start-date))) ;; List of events @@ -507,6 +553,7 @@ calendars))) ;; Events which started before our start point, but "spill" into our time span. + #; (section (@ (class "text-day")) (header (h2 "Tidigare")) ,@(stream->list @@ -514,6 +561,7 @@ (stream-take-while (compose (cut date/-time start-date) (extract 'DTSTART)) (cdr (stream-car evs)))))) + #; ,@(stream->list (stream-map fmt-day evs))))))))) @@ -534,7 +582,10 @@ (let ((fname (format #f "./html/~a.html" (date->string start-date "~1")))) (format (current-error-port) "Writing to [~a]~%" fname) (with-output-to-file fname - (lambda () (html-generate calendars events start-date end-date render-calendar))))]) + (lambda () (html-generate calendars events start-date end-date render-calendar + next-start: month+ + prev-start: month- + ))))]) (let ((ms (month-stream start-date))) (with-streams (take count @@ -555,7 +606,14 @@ ;; TODO It actually produces almost all date links wrong (lambda () (html-generate calendars events ;; Appends for case where before or after is empty - (car (append before current)) - (last (append current after)) - render-calendar-table)))))) + (car current) (date- (if (null? after) + (last current) + (car after)) + (date day: 1)) + 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)))) -- cgit v1.2.3