diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-10 16:06:33 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-10 16:06:33 +0200 |
commit | 3d2c2ba29c7fa6854e3734ce3d8635a37b6ecc2a (patch) | |
tree | b2b57154b35d8baa43ece77a2d891020f92a76f1 /module/output/html.scm | |
parent | Simplify term input. (diff) | |
download | calp-3d2c2ba29c7fa6854e3734ce3d8635a37b6ecc2a.tar.gz calp-3d2c2ba29c7fa6854e3734ce3d8635a37b6ecc2a.tar.xz |
Start breaking apart HTML modules.
Diffstat (limited to 'module/output/html.scm')
-rw-r--r-- | module/output/html.scm | 509 |
1 files changed, 213 insertions, 296 deletions
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 "<!doctype HTML>\n") (;;(@ (ice-9 pretty-print) pretty-print) (@ (sxml simple) sxml->xml) - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") - ;; "<!doctype html>" - (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 <template> element, but there is some - ;; form of special case with those in xhtml, but I can't find - ;; the documentation for it. - ,@(let* ((cal (vcalendar - name: "Generated" - children: (list (vevent - ;; The event template SHOULD lack - ;; a UID, to stop potential problems - ;; with conflicts when multiple it's - ;; cloned mulitple times. - dtstart: (datetime) - dtend: (datetime) - summary: "New Event")))) - (event (car (children cal)))) - `((div (@ (class "template event-container") (id "event-template") - ;; Only needed to create a duration. So actual dates - ;; dosen't matter - (data-start "2020-01-01") - (data-end "2020-01-02")) - ,(caddar ; strip <a> tag - (make-block event `((class " generated "))))) - (div (@ (class "template") (id "popup-template")) - ,(popup event (string-append "popup" (html-id event))))))))))) + ,(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 <template> element, but there is some + ;; form of special case with those in xhtml, but I can't find + ;; the documentation for it. + ,@(let* ((cal (vcalendar + name: "Generated" + children: (list (vevent + ;; The event template SHOULD lack + ;; a UID, to stop potential problems + ;; with conflicts when multiple it's + ;; cloned mulitple times. + dtstart: (datetime) + dtend: (datetime) + summary: "New Event")))) + (event (car (children cal)))) + `((div (@ (class "template event-container") (id "event-template") + ;; Only needed to create a duration. So actual dates + ;; dosen't matter + (data-start "2020-01-01") + (data-end "2020-01-02")) + ,(caddar ; strip <a> tag + (make-block event `((class " generated "))))) + (div (@ (class "template") (id "popup-template")) + ,(popup event (string-append "popup" (html-id event)))))))))) |