From a56ea7dd10cb6bf7a06cefc02214ed859dc5b796 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 19 Mar 2020 19:52:27 +0100 Subject: Minor cleanup and movement in html. --- module/output/html.scm | 143 ++++++++++++++++++++++++++++--------------------- 1 file changed, 81 insertions(+), 62 deletions(-) (limited to 'module') diff --git a/module/output/html.scm b/module/output/html.scm index 42955f34..9495a2db 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -20,18 +20,12 @@ #:use-module (parameters) ) -(define (td param) - (lambda (d) `(td (@ ,(map (lambda (p) - (cons `(quote ,(car p)) - (cdr p))) - param)) ,d))) (define (date-link date) (date->string date "~Y-~m-~d")) -(define x-pos (make-object-property)) -(define width (make-object-property)) - +;; Generate an UID for an event +;; TODO currently not guaranteed to be unique (define (UID ev) (string-append ;; (date/-time->string (attr ev 'DTSTART) "~s") @@ -39,6 +33,58 @@ (time->string (as-time (attr ev 'DTSTART)) "~H~M~S") (html-attr (attr ev 'UID)))) +;; This should only be used on time intervals, never on absolute times. +;; For that see @var{date->decimal-hour}. +;; NOTE Above comment probably deprecated +(define (time->decimal-hour time) + (exact->inexact (+ (hour time) + (/ (minute time) 60) + (/ (second time) 3600)))) + +;; Retuns an HTML-safe version of @var{str}. +(define (html-attr str) + (define cs (char-set-adjoin char-set:letter+digit #\- #\_)) + (string-filter (lambda (c) (char-set-contains? cs c)) str)) + +;; Takes an event, and returns a pretty string for the time interval +;; the event occupies. +(define (fmt-time-span ev) + (cond [(attr ev 'DTSTART) date? + => (lambda (s) + (cond [(attr ev 'DTEND) + => (lambda (e) + (if (date= e (date+ s (date day: 1))) + (values (date->string s) "") + (values (date->string s) + (date->string e))))] + [else (date->string s)]))] + [else ; guaranteed datetime + (let ((s (attr ev 'DTSTART)) + (e (attr ev 'DTEND))) + (let ((s-str (time->string (get-time s) "~H:~M")) + (e-str (time->string (get-time e) "~H:~M"))) + (if (date= (get-date s) (get-date e)) + (values s-str e-str) + (values (string-append (date->string (get-date s) "~Y-~m-~d ") s-str) + (string-append (date->string (get-date e) "~Y-~m-~d ") e-str)))))])) + + + + +;; Given a list, partitions it up into sublists of width length, +;;; each starting with 'tr. +(define (tablify list width) + (unless (null? list) + (let* ((row rest (split-at list width))) + (cons `(tr ,@row) + (tablify rest width))))) + + + + +(define x-pos (make-object-property)) +(define width (make-object-property)) + ;; Takes a list of vcomponents, sets their widths and x-positions to optimally ;; fill out the space, without any overlaps. (define (fix-event-widths! date lst) @@ -61,17 +107,6 @@ (inner (+ x w) (left-subtree tree)) (inner x (right-subtree tree)))))) -;; This should only be used on time intervals, never on absolute times. -;; For that see @var{date->decimal-hour}. -;; NOTE Above comment probably deprecated -(define (time->decimal-hour time) - (exact->inexact (+ (hour time) - (/ (minute time) 60) - (/ (second time) 3600)))) - -(define (html-attr str) - (define cs (char-set-adjoin char-set:letter+digit #\- #\_)) - (string-filter (lambda (c) (char-set-contains? cs c)) str)) (define (create-block-general date ev fmt) ;; (define time (date->time-utc day)) @@ -158,37 +193,13 @@ ,time ":00"))) (iota 12 0 2)))))) -(define (include-css path . extra-attributes) - `(link (@ (type "text/css") - (rel "stylesheet") - (href ,path) - ,@extra-attributes))) - -(define (include-alt-css path . extra-attributes) - `(link (@ (type "text/css") - (rel "alternate stylesheet") - (href ,path) - ,@extra-attributes))) +(define-public (render-calendar event-groups) + `(div (@ (class "calendar")) + ,(time-marker-div) + (div (@ (class "days")) + ,@(stream->list (stream-map lay-out-day event-groups))))) -(define (fmt-time-span ev) - (cond [(attr ev 'DTSTART) date? - => (lambda (s) - (cond [(attr ev 'DTEND) - => (lambda (e) - (if (date= e (date+ s (date day: 1))) - (values (date->string s) "") - (values (date->string s) - (date->string e))))] - [else (date->string s)]))] - [else ; guaranteed datetime - (let ((s (attr ev 'DTSTART)) - (e (attr ev 'DTEND))) - (let ((s-str (time->string (get-time s) "~H:~M")) - (e-str (time->string (get-time e) "~H:~M"))) - (if (date= (get-date s) (get-date e)) - (values s-str e-str) - (values (string-append (date->string (get-date s) "~Y-~m-~d ") s-str) - (string-append (date->string (get-date e) "~Y-~m-~d ") e-str)))))])) + ;; For sidebar, just text @@ -228,14 +239,23 @@ (attr ev 'DTSTART))) events)))))) + + + + +(define (include-css path . extra-attributes) + `(link (@ (type "text/css") + (rel "stylesheet") + (href ,path) + ,@extra-attributes))) + +(define (include-alt-css path . extra-attributes) + `(link (@ (type "text/css") + (rel "alternate stylesheet") + (href ,path) + ,@extra-attributes))) + -;; Given a list, partitions it up into sublists of width length, -;;; each starting with 'tr. -(define (tablify list width) - (unless (null? list) - (let* ((row rest (split-at list width))) - (cons `(tr ,@row) - (tablify rest width))))) ;; date should be start of month @@ -276,14 +296,9 @@ (tablify lst 7)))))) -(define repo-url (make-parameter "https://git.hornquist.se")) + -(define-public (render-calendar event-groups) - `(div (@ (class "calendar")) - ,(time-marker-div) - (div (@ (class "days")) - ,@(stream->list (stream-map lay-out-day event-groups))))) (define (make-small-block event) `(a (@ (href "#" ,(UID event)) @@ -324,11 +339,15 @@ (stream-cdr event-groups)))))) + + + ;;; NOTE ;;; The side bar filters all earlier events for each day to not create repeats, ;;; and the html-generate procedure also filters, but instead to find earlier eventns. ;;; All this filtering is probably slow, and should be looked into. +(define repo-url (make-parameter "https://git.hornquist.se")) (define-public (html-generate calendars events start-date end-date render-calendar) -- cgit v1.2.3