From e99bfabc327f9b3eb8540b05885845995a9fc55f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 30 Apr 2019 01:11:12 +0200 Subject: Add HTML sidebar, various formatting. --- module/output/html.scm | 141 ++++++++++++++++++++++++++++++++++++++++--------- static/style.css | 79 +++++++++++++++++++++++++++ 2 files changed, 194 insertions(+), 26 deletions(-) diff --git a/module/output/html.scm b/module/output/html.scm index a26f05e6..6fb23a9c 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -16,6 +16,12 @@ #:use-module (parameters) #:use-module (config)) +(define (date-link date) + (date->string date "~Y-~m-~d")) + +(define (time-link time) + (time->string time "~Y-~m-~d")) + (define x-pos (make-object-property)) (define width (make-object-property)) @@ -69,42 +75,40 @@ ;; height (* 100/24 (time->decimal-hour (event-length/day ev time))))) - `(div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME))) - (if (pair? l) (car l) l))) - ,(if (timestring (attr ev 'DTSTART) "~s") ,(attr ev 'UID))) + (div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME))) + (if (pair? l) (car l) l))) + ,(when (timestring date)) (fix-event-widths! (date->time-utc date) (stream->list events)) `(div (@ (class "day")) (div (@ (class "meta")) - ,(let ((str (date->string date "~Y-~m-~d"))) + ,(let ((str (date-link date))) `(span (@ (id ,str) (class "daydate")) ,str)) (span (@ (class "dayname")) ,(date->string date "~a"))) (div (@ (class "events")) ,@(map (lambda (time) - `(div (@ (class "clock " - ,(string-append "clock-" time))) " ")) - (map number->string (iota 12 0 2))) + `(div (@ (class "clock clock-" time)) "")) + (iota 12 0 2)) ,@(stream->list (stream-map (lambda (e) (vevent->sxml date e)) events)))))) (define (time-marker-div) `(div (@ (class "sideclock")) (div (@ (class "day")) - (div (@ (class "meta")) #\space) + (div (@ (class "meta")) "") (div (@ (class "clockbar")) ,@(map (lambda (time) - `(div (@ (class "clock " - ,(string-append "clock-" time))) + `(div (@ (class "clock clock-" ,time)) (span (@ (class "clocktext")) - ,(string-append time ":00")))) - (map number->string (iota 12 0 2))))))) + ,time ":00"))) + (iota 12 0 2)))))) (define (include-css path) `(link (@ (type "text/css") @@ -115,6 +119,81 @@ '((from (value #t) (single-char #\f)) (to (value #t) (single-char #\t)))) +(define (fmt-time-span ev) + (let* ((fmt (if (timestring (attr ev 'DTSTART) fmt)) + (end (time->string (attr ev 'DTEND) fmt))) + (values start end))) + +(define (fmt-single-event ev) + `(article (@ (id ,(time->string (attr ev 'DTSTART) "~s") + ,(html-attr (attr ev 'UID))) + (class "eventtext CAL_bg_" + ,(html-attr (let ((l (attr (parent ev) 'NAME))) + (if (pair? l) (car l) l))))) + (h1 (a (@ (href "#" ,(time-link (attr ev 'DTSTART)))) + ,(attr ev 'SUMMARY))) + (main + ,(let* ((start end (fmt-time-span ev))) + `(div ,start " — " ,end)) + ,(when (and=> (attr ev 'LOCATION) (negate string-null?)) + `(div (b "Plats: ") ,(attr ev 'LOCATION))) + ,(attr ev 'DESCRIPTION)))) + +(define (fmt-day day) + (let* (((date . events) day)) + `(div (@ (class "text-day")) + ;; TODO this gives date +1 + (header (h2 ,(let ((s (date->string date "~Y-~m-~d"))) + `(a (@ (href "#" ,s)) ,s)))) + ,@(map fmt-single-event (stream->list events))))) + +(define (days-in-month n) + (cond ((memv n '(1 3 5 7 8 10 12)) 31) + ((memv n '(4 6 9 11)) 30) + ;; TODO leap years + (else 28))) + +(define (previous-month n) + (1+ (modulo (- n 2) 12))) + +(define (next-month n) + (1+ (modulo n 12))) + +(define (td param) + (lambda (d) `(td (@ ,(map (lambda (p) + (cons `(quote ,(car p)) + (cdr p))) + param)) ,d))) + +;; 0 indexed, starting at monday. +(define (week-day date) + (modulo (1- (date-week-day date)) 7)) + +;; date should be start of month +(define (cal-table date) + (let ((td (lambda (p) (lambda (d) `(td (@ ,p) ,d))))) + `(table (@ (class "small-calendar")) + (thead (tr ,@(map (lambda (d) `(td ,d)) '(MÅ TI ON TO FR LÖ SÖ)))) + (tbody ,@(let recur + ((lst (let* ((month (date-month date)) + (month-len (days-in-month month)) + (prev-month-len (days-in-month (previous-month month))) + (month-start (week-day date))) + (append (map (td '(class "prev")) + (iota month-start (- prev-month-len month-start))) + (map (td '(class "cur")) + (map (lambda (d) `(a (@ (href "#" ,(date->string date "~Y-~m-") ,d)) ,d)) + (iota month-len 1))) + (map (td '(class "next")) + (iota (modulo (- (* 7 5) month-len month-start) 7) 1)))))) + (unless (null? lst) + (let* ((w rest (split-at lst 7))) + (cons `(tr ,@w) + (recur rest))))))))) + (define-public (html-main calendars events args) (define opts (getopt-long args opt-spec)) @@ -130,15 +209,25 @@ (title "Calendar") (meta (@ (charset "utf-8"))) ,(include-css "static/style.css") - (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%~}" + (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}" (map (lambda (c) - (list (html-attr (if (pair? (attr c 'NAME)) - (car (attr c 'NAME)) - (attr c 'NAME))) - (or (attr c 'COLOR) "white") - (or (and=> (attr c 'COLOR) calculate-fg-color) "black"))) + (let* ((name (html-attr (if (pair? (attr c 'NAME)) + (car (attr c 'NAME)) + (attr c 'NAME)))) + (bg-color (attr c 'COLOR)) + (fg-color (and=> (attr c 'COLOR) + calculate-fg-color))) + (list name (or bg-color 'white) (or fg-color 'black) + name (or bg-color 'black)))) calendars)))) - (body (div (@ (class "calendar")) + (body + (div (@ (class "root")) + (div (@ (class "calendar")) ,(time-marker-div) (div (@ (class "days")) - ,@(stream->list (stream-map lay-out-day evs)))))))) + ,@(stream->list (stream-map lay-out-day evs)))) + (div (@ (class "sideinfo")) + (div (@ (class "about")) + (div ,(cal-table (parse-freeform-date "2019-04-01")))) + (div (@ (class "eventlist")) + ,@(stream->list (stream-map fmt-day evs))))))))) diff --git a/static/style.css b/static/style.css index 3c3e7e9d..44ee6e0c 100644 --- a/static/style.css +++ b/static/style.css @@ -1,5 +1,84 @@ +.root { + display: flex; + margin: 0; + max-width: 100%; + height: 100%; +} + +.small-calendar { + text-align: right; +} + +.small-calendar .prev, +.small-calendar .next { + color: grey; +} + +.small-calendar td:nth-child(7).cur { + color: red; +} + +.small-calendar a { + color: inherit; + text-decoration: none; +} + +.text-day { + border-left: 2px solid black; + border-top: 2px solid black; + padding-left: 2px; + margin-top: 1em; +} + +.text-day header h2 { + width: 100%; + text-align: center; + font-size: 14pt; +} + +.sideinfo { + width: 20em; + height: 100%; +} + +.sideinfo .about { + display: flex; + justify-content: center; + height: 20%; +} + +.sideinfo .eventlist { + overflow: scroll; + max-height: 80%; +} + +.sideinfo .eventlist article { + border-bottom: 1px solid black; + margin-top: 1em; + border-left-style: solid; + border-left-width: 6px; + padding-left: 2px; +} + +.sideinfo .eventlist main { + white-space: pre-line; + font-size: 10pt; +} + +.sideinfo .eventlist h1 { + font-size: 12pt; + border-bottom: 1px solid gray; + margin-bottom: 0; +} + +.sideinfo .eventlist h1 a { + color: black; + text-decoration: none; +} + .calendar { height: 100%; + max-width: calc(100% - 20em); display: flex; } -- cgit v1.2.3