HTML work.

5 files changed, 175 insertions, 101 deletions

diff --git a/module/html/util.scm b/module/html/util.scm
new file mode 100644
index 00000000..36b1d929
--- /dev/null
+++ b/module/html/util.scm
@@ -0,0 +1,20 @@
+(define-module (html util)
+  :use-module (util))
+
+;; Retuns an HTML-safe version of @var{str}.
+(define-public (html-attr str)
+  (define cs (char-set-adjoin char-set:letter+digit #\- #\_))
+  (string-filter (lambda (c) (char-set-contains? cs c)) str))
+
+(define-public (date-link date)
+  ((@ (datetime) date->string) date "~Y-~m-~d"))
+
+
+
+;; Generate an html id for an event.
+;; TODO? same event placed multiple times, when spanning multiple cells
+(define-public html-id
+  (let ((id (make-object-property)))
+   (lambda (ev)
+     (or (id ev)
+         (set/r! (id ev) (symbol->string (gensym "__html_id_")))))))
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))))
diff --git a/module/output/html-search.scm b/module/output/html-search.scm
index f6b74a77..070a725e 100644
--- a/module/output/html-search.scm
+++ b/module/output/html-search.scm
@@ -5,6 +5,7 @@
   :use-module (vcomponent search)
   :use-module ((ice-9 pretty-print) :select (pretty-print))
   :use-module (html components)
+  :use-module (html vcomponent)
   )
 
 (define-public (search-result-page
@@ -23,9 +24,7 @@
      (input (@ (type submit))))
     (h2 "Result (page " ,page ")")
     (ul
-     ,@(for event in search-result
-            `(li (@ (class "event"))
-                 ,(prop event 'SUMMARY))))
+     ,@(compact-event-list search-result))
     (div (@ (class "paginator"))
          ,@(paginator->list
             paginator
diff --git a/module/output/html.scm b/module/output/html.scm
index 0145a943..3125f38b 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -13,13 +13,14 @@
   #:use-module (util tree)
   #:duplicates (last)
   #:use-module (datetime)
-  #:use-module (output general)
   #:use-module (ice-9 curried-definitions)
   #:use-module (ice-9 match)
   #:use-module (text util)
   #:use-module (vcomponent datetime output)
 
   #:use-module (html components)
+  #:use-module (html util)
+  #:use-module (html vcomponent)
 
   #:autoload (vcomponent instance) (global-event-object)
 
@@ -40,23 +41,6 @@
   "Makes the document editable"
   post: edit-mode)
 
-
-
-(define (date-link date)
-  (date->string date "~Y-~m-~d"))
-
-;; Generate an html id for an event.
-;; TODO? same event placed multiple times, when spanning multiple cells
-(define (html-id ev)
-  (or (prop ev '-HTML-ID)
-      (set/r! (prop ev '-HTML-ID)
-              (symbol->string (gensym "__html_id_")))))
-
-;; Retuns an HTML-safe version of @var{str}.
-(define (html-attr str)
-  (define cs (char-set-adjoin char-set:letter+digit #\- #\_))
-  (string-filter (lambda (c) (char-set-contains? cs c)) str))
-
 
 
 
@@ -289,77 +273,6 @@
                     (get-groups-between (group-stream (list->stream short-events))
                                         start-date end-date))))))))
 
-
-
-;; For sidebar, just text
-(define* (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 (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))))))
 
 
 ;;; Table output
@@ -605,15 +518,7 @@
      ,(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))))
+     ,(calendar-styles calendars))
 
     (body
      (div (@ (class "root"))
diff --git a/static/style.css b/static/style.css
index 563a8fa1..193cc1fb 100644
--- a/static/style.css
+++ b/static/style.css
@@ -671,6 +671,19 @@ along with their colors.
     display: inline-block;
 }
 
+.summary-line {
+    display: inline-flex;
+}
+
+.summary-line > * {
+    display: inline-block;
+}
+
+.summary-line time {
+    font-family: monospace;
+    min-width: 18ch;
+}
+
 /* Popups
 ----------------------------------------
 */
@@ -809,6 +822,15 @@ along with their colors.
 }
 
 
+.summary-line .square {
+    margin-right: 1em;
+}
+
+.square {
+    width: 1em;
+    height: 1em;
+}
+
 /* Icalendar
 ----------------------------------------
 */