From e028543baa552aa091fe3485b03da48d25ab8179 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 10 Aug 2020 17:23:34 +0200 Subject: Really start breaking apart HTML. --- module/html/view/calendar.scm | 335 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 335 insertions(+) create mode 100644 module/html/view/calendar.scm (limited to 'module/html/view/calendar.scm') diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm new file mode 100644 index 00000000..da1d6c9b --- /dev/null +++ b/module/html/view/calendar.scm @@ -0,0 +1,335 @@ +(define-module (html view calendar) + :use-module (util) + :use-module (vcomponent) + :use-module ((vcomponent datetime) + :select (events-between)) + :use-module ((vcomponent build) + :select (vcalendar vevent)) + :use-module (util config) + :use-module (datetime) + :use-module (html components) + :use-module ((html vcomponent) + :select (popup + calendar-styles + fmt-day + make-block + fmt-single-event + )) + :use-module (html config) + :use-module (html util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module ((vcomponent group) + :select (group-stream get-groups-between)) + :use-module ((git) + :select (get-git-version)) + ) + +;; date should be start of month +;; @example +;; må ti on to fr lö sö +;; 1 2 3 4 5 6 7 +;; 8 9 10 11 12 13 14 +;; 15 16 17 18 19 20 21 +;; 22 23 24 25 26 27 28 +;; 29 30 +;; @end example +;; date - a date in the month to display +;; week-start - which day the week begins on, see (datetime util) +(define* (cal-table key: start-date end-date next-start prev-start + (week-start (get-config 'week-start))) + + (define (td date) + `(a (@ ,@(cond + ;; We are before our time interval + [(date< date start-date) + ;; TODO find a prettier way to generate links to previous and next time intervals + `((class "prev") + (href ,(date->string + (stream-find (lambda (d) (date<= d date (next-start d))) + (stream-iterate prev-start start-date)) + "~Y-~m-~d.html") + "#" ,(date-link date)))] + ;; We are after our time interval + [(date< end-date date) + `((class "next") + (href ,(date->string + (stream-find (lambda (d) (and (date<= d date) + (date< date (next-start d)))) + (stream-iterate next-start start-date)) + "~Y-~m-~d.html") + "#" ,(date-link date)))] + ;; We are in our time interval + [else `((href "#" ,(date-link date)))])) + ;; NOTE This time object is the correct place to show the existance + ;; of an event on a given day in this small calendar. For example + ;; making the text red for all holidays, or creating a yellow background + ;; for events from a specific source. + (time (@ (datetime ,(date->string date "~Y-~m-~d"))) ,(day date)))) + + (let* ((last-months current next + (month-days (start-of-month start-date) week-start)) + (events (append last-months current next))) + `(div (@ (class "small-calendar")) + (div (@ (class "column-head row-head")) "v.") + ,@(map (lambda (d) `(div (@ (class "column-head")) + ,(string-titlecase (week-day-name d 2)))) + (weekday-list week-start)) + ,@(let ((first (start-of-week (car events) week-start)) + (last (start-of-week (last events) week-start))) + (map (lambda (v) `(div (@ (class "row-head")) ,v)) + (map (lambda (d) (week-number d week-start)) + (stream->list + (stream-take-while (lambda (s) (date<= s last)) + (week-stream first)))))) + ,@(map td events + )))) + + + + +;;; Main-stuff + + +;;; 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 + key: + (intervaltype 'all) ; 'week | 'month | 'all + calendars events start-date end-date + render-calendar ; (bunch of kv args) → (list sxml) + next-start ; date → date + prev-start ; date → date + ;; The pre and post dates are if we want to show some dates just + ;; outside our actuall interval. Primarily for whole month views, + ;; which needs a bit on each side. + (pre-start start-date) + (post-end end-date)) + + ;; NOTE maybe don't do this again for every month + (define evs (get-groups-between (group-stream events) + start-date end-date)) + + (define (nav-link display date) + `(a (@ (href ,(date->string date "~Y-~m-~d") ".html") + (class "nav hidelink")) + (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") + (;;(@ (ice-9 pretty-print) pretty-print) + (@ (sxml simple) sxml->xml) + (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"))) + ,(calendar-styles 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