diff options
Diffstat (limited to 'module/calp/html/vcomponent.scm')
-rw-r--r-- | module/calp/html/vcomponent.scm | 229 |
1 files changed, 229 insertions, 0 deletions
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm new file mode 100644 index 00000000..be6b6166 --- /dev/null +++ b/module/calp/html/vcomponent.scm @@ -0,0 +1,229 @@ +(define-module (calp html vcomponent) + :use-module (util) + :use-module (vcomponent) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (datetime) + :use-module (calp html util) + :use-module ((calp html config) :select (edit-mode)) + :use-module ((calp html components) :select (btn tabset)) + :use-module ((util color) :select (calculate-fg-color)) + :use-module ((vcomponent datetime output) + :select (fmt-time-span + format-description + format-summary + format-recurrence-rule + )) + ) + +(define-public (compact-event-list list) + + (define calendars + (delete-duplicates! + (filter (lambda (x) (eq? 'VCALENDAR (type x))) + (map parent list)) + eq?)) + + (define (summary event) + `(summary (div (@ (class "summary-line ")) + (span (@ (class "square CAL_" + ,(html-attr + (or (prop (parent event) + 'NAME) + "unknown"))))) + (time ,(let ((dt (prop event 'DTSTART))) + (if (datetime? dt) + (datetime->string dt "~Y-~m-~d ~H:~M") + (date->string dt "~Y-~m-~d" )))) + (span ,(prop event 'SUMMARY))))) + (cons + (calendar-styles calendars) + (for event in list + `(details + ,(summary event) + ;; TODO better format, add show in calendar button + ,(fmt-single-event event))))) + +;; Format event as text. +;; Used in +;; - sidebar +;; - popup overwiew tab +;; - search result (event details) +(define*-public (fmt-single-event ev + optional: (attributes '()) + key: (fmt-header list)) + ;; (format (current-error-port) "fmt-single-event: ~a~%" (prop ev 'X-HNH-FILENAME)) + `(div (@ ,@(assq-merge + attributes + `((class " eventtext " + ,(when (and (prop ev 'PARTSTAT) + (eq? 'TENTATIVE (prop ev 'PARTSTAT))) + " tentative "))))) + (h3 ,(fmt-header + (when (prop ev 'RRULE) + `(span (@ (class "repeating")) "↺")) + `(span (@ (class "summary")) ,(prop ev 'SUMMARY)))) + (div + ,(call-with-values (lambda () (fmt-time-span ev)) + (case-lambda [(start) + `(div (time (@ (class "dtstart") + (data-fmt ,(string-append "~L" start)) + (datetime ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + "~1T~3"))) + ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + start)))] + [(start end) + `(div (time (@ (class "dtstart") + (data-fmt ,(string-append "~L" start)) + (datetime ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + "~1T~3"))) + ,(datetime->string (as-datetime (prop ev 'DTSTART)) + start)) + " — " + (time (@ (class "dtend") + (data-fmt ,(string-append "~L" end)) + (datetime ,(datetime->string + (as-datetime (prop ev 'DTSTART)) + "~1T~3"))) + ,(datetime->string (as-datetime (prop ev 'DTEND)) + end)))])) + ,(when (and=> (prop ev 'LOCATION) (negate string-null?)) + `(div (b "Plats: ") + (div (@ (class "location")) + ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) + (prop ev 'LOCATION))))) + ,(awhen (prop ev 'DESCRIPTION) + `(span (@ (class "description")) + ,(format-description ev it))) + ,(awhen (prop ev 'RRULE) + `(span (@ (class "rrule")) + ,@(format-recurrence-rule ev))) + ,(when (prop ev 'LAST-MODIFIED) + `(span (@ (class "last-modified")) "Senast ändrad " + ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M"))) + + ))) + + +;; Single event in side bar (text objects) +(define-public (fmt-day day) + (let* (((date . events) day)) + `(section (@ (class "text-day")) + (header (h2 ,(let ((s (date->string date "~Y-~m-~d"))) + `(a (@ (href "#" ,s) + (class "hidelink")) ,s)))) + ,@(stream->list + (stream-map + (lambda (ev) + (fmt-single-event + ev `((id ,(html-id ev)) + (class "CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")))) + fmt-header: + (lambda body + `(a (@ (href "#" ,(html-id ev) #; (date-link (as-date (prop ev 'DTSTART))) + ) + (class "hidelink")) + ,@body)))) + (stream-filter + (lambda (ev) + ;; If start was an earlier day + ;; This removes all descriptions from + ;; events for previous days, + ;; solving duplicates. + (date/-time<=? date (prop ev 'DTSTART))) + events)))))) + + +(define-public (calendar-styles calendars) + `(style + ,(format #f "~:{.CAL_~a { --color: ~a; --complement: ~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)))) + calendars)))) + +;; "Physical" block in calendar view +(define*-public (make-block ev optional: (extra-attributes '())) + + `((a (@ (href "#" ,(html-id ev)) + (class "hidelink")) + (div (@ ,@(assq-merge + extra-attributes + `((id ,(html-id ev)) + (data-calendar ,(html-attr (or (prop (parent ev) 'NAME) "unknown"))) + (class "event CAL_" ,(html-attr (or (prop (parent ev) 'NAME) + "unknown")) + ,(when (and (prop ev 'PARTSTAT) + (eq? 'TENTATIVE (prop ev 'PARTSTAT))) + " tentative") + ,(when (and (prop ev 'TRANSP) + (eq? 'TRANSPARENT (prop ev 'TRANSP))) + " transparent") + ) + (onclick "toggle_popup('popup' + this.id)") + ))) + ;; Inner div to prevent overflow. Previously "overflow: none" + ;; was set on the surounding div, but the popup /needs/ to + ;; overflow (for the tabs?). + (div (@ (class "event-body")) + ,(when (prop ev 'RRULE) + `(span (@ (class "repeating")) "↺")) + (span (@ (class "summary")) + ,(format-summary ev (prop ev 'SUMMARY))) + ,(when (prop ev 'LOCATION) + `(span (@ (class "location")) + ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) + (prop ev 'LOCATION))))) + (div (@ (style "display:none !important;")) + ,((@ (vcomponent xcal output) ns-wrap) + ((@ (vcomponent xcal output) vcomponent->sxcal) + ev))))))) + + +(define (repeat-info event) + `(div (@ (class "eventtext")) + (h2 "Upprepningar") + (pre ,(prop event 'RRULE)))) + + +(define-public (popup ev id) + `(div (@ (id ,id) (class "popup-container CAL_" + ,(html-attr (or (prop (parent ev) 'NAME) + "unknown"))) + (onclick "event.stopPropagation()")) + ;; TODO all (?) code uses .popup-container as the popup, while .popup sits and does nothing. + ;; Do something about this? + (div (@ (class "popup")) + (nav (@ (class "popup-control")) + ,(btn "×" + title: "Stäng" + onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" + class: '("close-tooltip")) + ,(when (edit-mode) + (list + (btn "🖊️" + title: "Redigera" + onclick: "place_in_edit_mode(document.getElementById(this.closest('.popup-container').id.substr(5)))") + (btn "🗑" + title: "Ta bort" + onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")))) + + ,(tabset + `(("📅" title: "Översikt" + ,(fmt-single-event ev)) + ("⤓" title: "Nedladdning" + (div (@ (class "eventtext") (style "font-family:sans")) + (h2 "Ladda ner") + (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) + "som iCal")) + (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) + "som xCal"))))) + ,@(when (prop ev 'RRULE) + `(("↺" title: "Upprepningar" class: "repeating" + ,(repeat-info ev))))))))) |