From 3d2c2ba29c7fa6854e3734ce3d8635a37b6ecc2a 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:06:33 +0200
Subject: Start breaking apart HTML modules.

---
 .gitignore                    |   2 +-
 module/html/components.scm    | 122 ++++++++++
 module/output/html-search.scm |  59 +++--
 module/output/html.scm        | 509 ++++++++++++++++++------------------------
 module/vcomponent/search.scm  |   1 +
 5 files changed, 366 insertions(+), 327 deletions(-)
 create mode 100644 module/html/components.scm

diff --git a/.gitignore b/.gitignore
index a6b94637..f4c88a51 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,2 @@
 *.x
-html
+/html
diff --git a/module/html/components.scm b/module/html/components.scm
new file mode 100644
index 00000000..77156fc5
--- /dev/null
+++ b/module/html/components.scm
@@ -0,0 +1,122 @@
+(define-module (html components)
+  :use-module (util)
+  :use-module (util exceptions)
+  :export (xhtml-doc)
+  )
+
+;; Wraps a number of sxml forms into a valid sxhtml-tree.
+(define-syntax xhtml-doc
+  (syntax-rules (@)
+    ((_ (@ attr ...) body ...)
+     `(*TOP*
+       (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+       (html (@ (xmlns "http://www.w3.org/1999/xhtml") attr ...)
+             body ...)))
+    ((_ body ...)
+     (xhtml-doc (@) body ...))))
+
+
+;; Add a slider with an associated number input. Keeps the two in check.
+;; Uses the js function setVar (which must be provided elsewhere)
+;; set the the value of @var{variable}.
+(define*-public (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)"))
+                 ))))
+
+;; Generates a button or button-like link.
+;; TODO <div/> inside <button/> isn't valid.
+(define*-public (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))))
+
+
+;; Creates a group of tabs from a given specification. The specification
+;; @var{elements} should be a list, where each element is a sublist on
+;; the form
+;; @example
+;; ("tab icon" arguments ... tab-body)
+;; @end example
+;; where arguments are zero or more pairs of keyword arguments. For example:
+;; @example
+;; ("📅" title: "Översikt" ,(fmt-single-event ev))
+;; @end example
+;; Creates a tab with an calendar emoji as icon, "Översikt" is sent as the
+;; extra argument #:title, and the body is the return from fmt-single-event.
+(define-public (tabset elements)
+  (define tabgroup (symbol->string (gensym "tabgroup")))
+
+  `(div (@ (class "tabgroup"))
+        ,@(for (i (key args ... body)) in (enumerate elements)
+               (define id (symbol->string (gensym "tab")))
+               `(div (@ (class "tab"))
+                     (input (@ (type "radio") (id ,id) (name ,tabgroup)
+                               ,@(when (zero? i) '((checked)))))
+                     (label (@ (for ,id) (style "top: " ,(* 6 i) "ex")
+                               ,(awhen (memv title: args)
+                                       `(title ,(cadr it))))
+                            ,key)
+                     (div (@ (class "content")) ,body)))))
+
+
+(define-public (include-css path . extra-attributes)
+  `(link (@ (type "text/css")
+            (rel "stylesheet")
+            (href ,path)
+            ,@extra-attributes)))
+
+
+(define-public (include-alt-css path . extra-attributes)
+  `(link (@ (type "text/css")
+            (rel "alternate stylesheet")
+            (href ,path)
+            ,@extra-attributes)))
diff --git a/module/output/html-search.scm b/module/output/html-search.scm
index a6a80cd4..f6b74a77 100644
--- a/module/output/html-search.scm
+++ b/module/output/html-search.scm
@@ -3,36 +3,35 @@
   :use-module (util)
   :use-module (vcomponent)
   :use-module (vcomponent search)
-  :use-module (ice-9 format)
+  :use-module ((ice-9 pretty-print) :select (pretty-print))
+  :use-module (html components)
   )
 
-(define-public (search-result-page search-term search-result page paginator q=)
-  `(*TOP*
-    (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-    (html (@ (xmlns "http://www.w3.org/1999/xhtml") (lang sv))
-          (head (title "Search results")
-                ;; TODO (@ (output html) include-css)
-                (link (@ (type "text/css")
-                         (rel "stylesheet")
-                         (href "/static/style.css"))))
-          (body
-           (h2 "Search term")
-           (form
-            (pre (textarea (@ (name "q") (rows 5) (spellcheck false)
-                              (style "width:100%"))
-                           ,(format #f "~y" search-term)))
-            (input (@ (type submit))))
-           (h2 "Result (page " ,page ")")
-           (ul
-            ,@(for event in search-result
-                   `(li (@ (class "event"))
-                        ,(prop event 'SUMMARY))))
-           (div (@ (class "paginator"))
-                ,@(paginator->list
-                   paginator
-                   (lambda (p) (if (= p page)
-                              `(span ,p)
-                              `(a (@ (href "?" ,q= "&p=" ,p)) ,p)))
-                   (lambda (p) `(a (@ (href "?" ,q= "&p=" ,p)) "»"))))
-           ))))
+(define-public (search-result-page
+                search-term search-result page paginator q=)
+  (xhtml-doc
+   (@ (lang sv))
+   (head (title "Search results")
+         ,(include-css "/static/style.css"))
+   (body
+    (h2 "Search term")
+    (form
+     (pre (textarea (@ (name "q") (rows 5) (spellcheck false)
+                       (style "width:100%"))
+                    ,(with-output-to-string
+                       (lambda () (pretty-print search-term)))))
+     (input (@ (type submit))))
+    (h2 "Result (page " ,page ")")
+    (ul
+     ,@(for event in search-result
+            `(li (@ (class "event"))
+                 ,(prop event 'SUMMARY))))
+    (div (@ (class "paginator"))
+         ,@(paginator->list
+            paginator
+            (lambda (p) (if (= p page)
+                       `(span ,p)
+                       `(a (@ (href "?" ,q= "&p=" ,p)) ,p)))
+            (lambda (p) `(a (@ (href "?" ,q= "&p=" ,p)) "»"))))
+    )))
 
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))))))))))
 
 
 
diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm
index 4e604d89..15ff0720 100644
--- a/module/vcomponent/search.scm
+++ b/module/vcomponent/search.scm
@@ -155,6 +155,7 @@
                   (set-max-page! paginator (max page (get-max-page paginator)))
                   result))))
     (lambda (err proc fmt args data)
+      ;; TODO ensure the error actually is index out of range.
       ;; (format (current-error-port) "~?~%" fmt args)
       (set-max-page! paginator (get-max-page paginator))
       (set-true-max-page! paginator)
-- 
cgit v1.2.3