From f31c92eec971a2d0a10e3ed4cc66235a86456d4a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 10 Aug 2020 16:44:57 +0200
Subject: HTML work.

---
 module/html/vcomponent.scm | 128 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 128 insertions(+)
 create mode 100644 module/html/vcomponent.scm

(limited to 'module/html/vcomponent.scm')

diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm
new file mode 100644
index 00000000..5e17932c
--- /dev/null
+++ b/module/html/vcomponent.scm
@@ -0,0 +1,128 @@
+(define-module (html vcomponent)
+  :use-module (util)
+  :use-module (vcomponent)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-41)
+  :use-module (datetime)
+  :use-module (html util)
+  :use-module ((output general) :select (calculate-fg-color))
+  :use-module ((vcomponent datetime output)
+               :select (fmt-time-span
+                        format-description
+                        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)))))
+
+;; For sidebar, just text
+(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))
+  `(article (@ ,@(assq-merge
+                  attributes
+                  `((class "eventtext CAL_bg_"
+                      ,(html-attr (or (prop (parent ev) 'NAME) "unknown"))
+                      ,(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 (span (@ (class "dtstart")
+                                                     (data-fmt "%L%H:%M"))
+                                                  ,start))]
+                             [(start end) `(div (span (@ (class "dtstart")
+                                                         ;; TODO same format string
+                                                         ;; as fmt-time-span used
+                                                         (data-fmt "%L%H:%M"))
+                                                      ,start)
+                                                " — "
+                                                (span (@ (class "dtend")
+                                                         (data-fmt "%L%H:%M"))
+                                                      ,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)))))
+             ,(and=> (prop ev 'DESCRIPTION)
+                     (lambda (str) (format-description ev str)))
+             ,(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)))
+                           fmt-header:
+                           (lambda body
+                             `(a (@ (href "#" ,(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 { 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))))
-- 
cgit v1.2.3