From 255f26030a2712f06722205ad593e4f7df0ed76c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 29 Apr 2020 00:11:57 +0200
Subject: Test tooltip library.

---
 module/output/html.scm | 88 +++++++++++++++++++++++++++++---------------------
 1 file changed, 51 insertions(+), 37 deletions(-)

(limited to 'module/output')

diff --git a/module/output/html.scm b/module/output/html.scm
index 8a932fd0..375cc03b 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -102,7 +102,7 @@
 
 
 
-(define* (btn key: onclick href
+(define* (btn key: onclick href (class '())
               allow-other-keys:
               rest: args)
   (when (and onclick href)
@@ -114,7 +114,7 @@
   (let ((body #f))
     `(,(cond [onclick 'button]
              [href 'a])
-      (@ (class "btn")
+      (@ (class ,(string-join (cons "btn" class) " "))
          ,(cond [onclick `(onclick ,onclick)]
                 [href `(href ,href)])
          ,@(let loop ((rem args))
@@ -130,19 +130,21 @@
       (div ,body))))
 
 
-(define (popup ev)
-  `(div (@ (class "popup"))
-        (nav (@ (class "popup-control CAL_" ,(html-attr (or (attr (parent ev) 'NAME)
-                                                            "unknown"))))
-             ,(btn "×"
-                   title: "Stäng"
-                   onclick: "close_popup(this)"
-                   )
-             ,(btn "📅"
-                   title: "Ladda ner"
-                   href: (string-append "/calendar/" (attr ev 'UID) ".ics")))
+(define (popup ev id)
+  `(div (@ (class "popup-container") (id ,id))
+        (div (@ (class "popup"))
+             (nav (@ (class "popup-control CAL_" ,(html-attr (or (attr (parent ev) 'NAME)
+                                                                 "unknown"))))
+                  ,(btn "×"
+                        title: "Stäng"
+                        onclick: "close_popup(this)"
+                        class: '("close-tooltip")
+                        )
+                  ,(btn "📅"
+                        title: "Ladda ner"
+                        href: (string-append "/calendar/" (attr ev 'UID) ".ics")))
 
-        ,(fmt-single-event ev)))
+             ,(fmt-single-event ev))))
 
 (define (data-attributes event)
   (hash-map->list
@@ -184,29 +186,33 @@
         (inner x (right-subtree tree))))))
 
 (define* (make-block ev optional: (extra-attributes '()))
-  `(div (@ ,@(assq-merge
-              extra-attributes
-              `((class "event CAL_" ,(html-attr (or (attr (parent ev) 'NAME)
-                                                    "unknown"))
-                  ,(when (and (attr ev 'PARTSTAT)
-                              (string= "TENTATIVE" (attr ev 'PARTSTAT)))
-                     " tentative"))
-                ;; TODO only if in debug mode?
-                ,@(data-attributes ev))))
-        (div (@ (class "event-inner"))
-             ;; NOTE These popup's are far from good. Main problem being that
-             ;; the often render off-screen for events high up on the screen.
-             ,(popup ev)
-             (a (@ (href "#" ,(UID ev))
-                   (class "hidelink"))
-                (div (@ (class "body"))
-                     ,(when (attr ev 'RRULE)
-                        `(span (@ (class "repeating")) "↺"))
-                     ,((get-config 'summary-filter) ev (attr ev 'SUMMARY))
-                     ,(when (attr ev 'LOCATION)
-                        `(span (@ (class "location"))
-                               ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
-                                            (attr ev 'LOCATION)))))))))
+
+  (define popup-id (symbol->string (gensym "popup")))
+
+  `((div (@ ,@(assq-merge
+               extra-attributes
+               `((class "event CAL_" ,(html-attr (or (attr (parent ev) 'NAME)
+                                                     "unknown"))
+                   ,(when (and (attr ev 'PARTSTAT)
+                               (string= "TENTATIVE" (attr ev 'PARTSTAT)))
+                      " tentative"))
+                 (data-tipped-options ,(format #f "inline: '~a'" popup-id))
+                 ;; TODO only if in debug mode?
+                 ,@(data-attributes ev))))
+         (div (@ (class "event-inner"))
+              ;; NOTE These popup's are far from good. Main problem being that
+              ;; the often render off-screen for events high up on the screen.
+              (a (@ (href "#" ,(UID ev))
+                    (class "hidelink"))
+                 (div (@ (class "body"))
+                      ,(when (attr ev 'RRULE)
+                         `(span (@ (class "repeating")) "↺"))
+                      ,((get-config 'summary-filter) ev (attr ev 'SUMMARY))
+                      ,(when (attr ev 'LOCATION)
+                         `(span (@ (class "location"))
+                                ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
+                                             (attr ev 'LOCATION))))))))
+    ,(popup ev popup-id)))
 
 ;; Format single event for graphical display
 (define (create-block date ev)
@@ -626,6 +632,14 @@
            ,(include-css "/static/style.css")
            ,(include-alt-css "/static/dark.css"  '(title "Dark"))
            ,(include-alt-css "/static/light.css" '(title "Light"))
+
+           ;; <script type="text/javascript" src="https://code.jquery.com/jquery-3.1.1.min.js"></script>
+           ;; <script type="text/javascript" src="tipped/dist/js/tipped.min.js"></script>
+           ;; <link rel="stylesheet" type="text/css" href="tipped/dist/css/tipped.css"/>
+           ,(include-css "http://gandalf.adrift.space:8000/tipped/dist/css/tipped.css")
+           (script (@ (src "https://code.jquery.com/jquery-3.1.1.min.js")) "")
+           (script (@ (src "http://gandalf.adrift.space:8000/tipped/dist/js/tipped.min.js")) "")
+
            (script (@ (src "/static/script.js")) "")
            (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}"
                            (map (lambda (c)
-- 
cgit v1.2.3