From 3d2c2ba29c7fa6854e3734ce3d8635a37b6ecc2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 10 Aug 2020 16:06:33 +0200 Subject: Start breaking apart HTML modules. --- module/output/html.scm | 509 +++++++++++++++++++++---------------------------- 1 file changed, 213 insertions(+), 296 deletions(-) (limited to 'module/output/html.scm') diff --git a/module/output/html.scm b/module/output/html.scm index 6e6fcd30..0145a943 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -19,6 +19,8 @@ #:use-module (text util) #:use-module (vcomponent datetime output) + #:use-module (html components) + #:autoload (vcomponent instance) (global-event-object) #:use-module (git) @@ -38,37 +40,7 @@ "Makes the document editable" post: edit-mode) -(define* (slider-input key: variable - (min 0) - (max 10) - (step 1) - (value 1) - (unit "")) - (let ((groupname (symbol->string (gensym "slider")))) - `(div (@ (class "input-group")) - (script - "function " ,groupname "fn (value) {" - "setVar('" ,variable "', value + '" ,unit "');" - "for (let el of document.getElementsByClassName('" ,groupname "')) {" - " el.value = value;" - "}}") - (input (@ (type "range") - (class ,groupname) - (min ,min) - (max ,max) - (step ,step) - (value ,value) - (oninput ,groupname "fn(this.value)") - )) - (input (@ (type "number") - (class ,groupname) - (min ,min) - (max ,max) - (step ,step) - (value ,value) - (oninput ,groupname "fn(this.value)")) - ) - ))) + (define (date-link date) (date->string date "~Y-~m-~d")) @@ -88,47 +60,6 @@ -(define* (btn key: onclick href (class '()) - allow-other-keys: - rest: args) - (when (and onclick href) - (error "Only give one of onclick, href and submit.")) - - (let ((body #f)) - `(,(cond [href 'a] - [else 'button]) - (@ (class ,(string-join (cons "btn" class) " ")) - ,@(cond [onclick `((onclick ,onclick))] - [href `((href ,href))] - [else '()]) - ,@(let loop ((rem args)) - (cond - [(null? rem) '()] - [(memv (car rem) '(onclick: href: class:)) - (loop (cddr rem))] - [(keyword? (car rem)) - (cons* `(,(keyword->symbol (car rem)) - ,(cadr rem)) - (loop (cddr rem)))] - [else - (set! body (car rem)) - (loop (cdr rem))]))) - (div ,body)))) - - -(define (tabset elements) - (define tabgroup (symbol->string (gensym "tabgroup"))) - - `(div (@ (class "tabgroup")) - ,@(for (i (key body)) in (enumerate elements) - (define id (symbol->string (gensym "tab"))) - `(div (@ (class "tab")) - (input (@ (type "radio") (id ,id) (name ,tabgroup) - ,@(when (zero? i) '((checked))))) - ;; TODO title attribute for label - (label (@ (for ,id) (style "top: " ,(* 6 i) "ex")) ,key) - (div (@ (class "content")) ,body))))) - (define (popup ev id) `(div (@ (class "popup-container") (id ,id) (onclick "event.stopPropagation()")) @@ -145,13 +76,15 @@ onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")) ,(tabset - `(("📅" ,(fmt-single-event ev)) - ("⤓" (div (@ (style "font-family:sans")) - (p "Ladda ner") - (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) - "som iCal")) - (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) - "som xCal")))))))))) + `(("📅" title: "Översikt" + ,(fmt-single-event ev)) + ("⤓" title: "Nedladdning" + (div (@ (style "font-family:sans")) + (p "Ladda ner") + (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) + "som iCal")) + (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) + "som xCal")))))))))) @@ -532,20 +465,6 @@ -;;; General HTML help - -(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))) - ;; date should be start of month @@ -652,215 +571,213 @@ ;; (display "\n") (;;(@ (ice-9 pretty-print) pretty-print) (@ (sxml simple) sxml->xml) - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") - ;; "" - (html (@ (xmlns "http://www.w3.org/1999/xhtml") (lang sv)) - (head - (title "Calendar") - (meta (@ (charset "utf-8"))) - ;; (meta (@ (http-equiv "Content-Type") (content "application/xhtml+xml"))) - (meta (@ (name viewport) - (content "width=device-width, initial-scale=0.5"))) - (meta (@ (name description) - (content "Calendar for the dates between " - ,(date->string start-date) " and " - ,(date->string end-date)))) - ;; NOTE this is only for the time actually part of this calendar. - ;; overflowing times from pre-start and post-end is currently ignored here. - (meta (@ (name start-time) - (content ,(date->string start-date "~s")))) - (meta (@ (name end-time) - (content ,(date->string (date+ end-date (date day: 1)) "~s")))) - - (script - "EDIT_MODE=true;") - - (style ,(format #f "html { + (xhtml-doc + (@ (lang sv)) + (head + (title "Calendar") + (meta (@ (charset "utf-8"))) + ;; (meta (@ (http-equiv "Content-Type") (content "application/xhtml+xml"))) + (meta (@ (name viewport) + (content "width=device-width, initial-scale=0.5"))) + (meta (@ (name description) + (content "Calendar for the dates between " + ,(date->string start-date) " and " + ,(date->string end-date)))) + ;; NOTE this is only for the time actually part of this calendar. + ;; overflowing times from pre-start and post-end is currently ignored here. + (meta (@ (name start-time) + (content ,(date->string start-date "~s")))) + (meta (@ (name end-time) + (content ,(date->string (date+ end-date (date day: 1)) "~s")))) + + (script + "EDIT_MODE=true;") + + (style ,(format #f "html { --editmode: 1.0; --event-font-size: 8pt; --gray: #757575; --btn-height: 0.5ex; }")) - ,(include-css "/static/style.css") - ,(include-alt-css "/static/dark.css" '(title "Dark")) - ,(include-alt-css "/static/light.css" '(title "Light")) - - (script (@ (defer) (src "/static/script.js"))) - (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}" - (map (lambda (c) - (let* ((name (html-attr (prop c 'NAME))) - (bg-color (prop c 'COLOR)) - (fg-color (and=> (prop c 'COLOR) - calculate-fg-color))) - (list name (or bg-color 'white) (or fg-color 'black) - name (or bg-color 'black)))) - calendars)))) - - (body - (div (@ (class "root")) - (main - ;; Actuall calendar - (@ (style "grid-area: main")) - ,@(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 - ) - - ,@(for event in (stream->list - (events-between pre-start post-end events)) - (popup event (string-append "popup" (html-id event))))) - - ;; Page footer - (footer - (@ (style "grid-area: footer")) - (span "Page generated " ,(date->string (current-date))) - (span (a (@ (href ,(repo-url) "/calparse")) - "Source Code")) - ,(let* ((long-hash short-hash (get-git-version)) - (url (format #f "~a/calparse/commit/?id=~a" - (repo-url) long-hash))) - `(span "Version " (a (@ (href ,url)) ,short-hash)))) - - ;; Small calendar and navigation - (nav (@ (class "calnav") (style "grid-area: nav")) - (div (@ (class "change-view")) - ,(btn href: (date->string - (if (= 1 (day start-date)) - (start-of-week start-date (get-config 'week-start)) - start-date) - "/week/~1.html") - "veckovy") - - ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") - "månadsvy") - - ,(btn id: "today-button" - href: (string-append - "/today?" (case intervaltype - [(month) "view=month"] - [(week) "view=week"] - [else ""])) - "idag")) - - (div (@ (id "jump-to")) - ;; Firefox's accessability complain about each date - ;; component, meaning that it's broken. This label - ;; is for the whole input, which can be enabled - ;; if wanted. - ;; (label (@ (for "date")) "Hoppa till") - (form (@ (action "/today")) - (input (@ (type hidden) - (name "view") - (value ,(case intervaltype - [(month week) => symbol->string] - [else "month"])))) - (input (@ (type date) - (name "date") - (value ,(date->string start-date "~1")))) - ,(btn "➔")))) - - (details (@ (open) (style "grid-area: cal")) - (summary "Month overview") - (div (@ (class "smallcall-head")) - ,(string-titlecase (date->string start-date "~B ~Y"))) - ;; NOTE it might be a good idea to put the navigation buttons - ;; earlier in the DOM-tree/tag order. At least Vimium's - ;; @key{[[} keybind sometimes finds parts of events instead. - (div (@ (class "smallcal")) - ;; prev button - ,(nav-link "«" (prev-start start-date)) - - ;; calendar table - (div ,(cal-table start-date: start-date end-date: end-date - next-start: next-start - prev-start: prev-start - )) - - ;; next button - ,(nav-link "»" (next-start start-date)))) - - - (div (@ (style "grid-area: details")) - ,(when (or (debug) (edit-mode)) - `(details (@ (class "sliders")) - (summary "Option sliders") - - - ,@(when (edit-mode) - `((label "Event blankspace") - ,(slider-input - variable: "editmode" - min: 0 - max: 1 - step: 0.01 - value: 1))) - - ,@(when (debug) - `((label "Fontsize") - ,(slider-input - unit: "pt" - min: 1 - max: 20 - step: 1 - value: 8 - variable: "event-font-size"))))) - - ;; List of calendars - (details (@ (class "calendarlist")) - (summary "Calendar list") - (ul ,@(map - (lambda (calendar) - `(li (@ (class "CAL_bg_" - ,(html-attr (prop calendar 'NAME)))) - ,(prop calendar 'NAME))) - calendars)))) - - ;; List of events - (div (@ (class "eventlist") - (style "grid-area: events")) - ;; Events which started before our start point, - ;; but "spill" into our time span. - (section (@ (class "text-day")) - (header (h2 "Tidigare")) - ,@(stream->list - (stream-map - fmt-single-event - (stream-take-while - (compose (cut date/-time start-date) - (extract 'DTSTART)) - (cdr (stream-car evs)))))) - ,@(stream->list (stream-map fmt-day evs)))) - - ;; This would idealy be a