Adding a tray icon.

info.rkt

@@ -1,7 +1,7 @@
 #lang info
 
 (define pkg-authors '(hnmdijkema))
-(define version "0.1.5")
+(define version "0.1.6")
 (define license 'MIT)   
 (define collection "racket-webview")
 (define pkg-desc "racket-webview - A Web Based GUI library, based on a Qt WebEngine backend")

racket-webview-qt.rkt

@@ -51,6 +51,12 @@
          rkt-webview-version
          rkt-webview-set-loglevel
          rkt-webview-info
+         ; tray specific
+         rkt-webview-tray-create
+         rkt-webview-tray-set-icon!
+         rkt-webview-tray-set-tooltip!
+         rkt-webview-tray-show-message
+         rkt-webview-tray-set-menu!
          )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -466,6 +472,25 @@
 (define-rktwebview rkt_webview_message_box
   (_fun _int _string/utf-8 _string/utf-8 _string/utf-8 _rkt_messagetype_t -> _rkt_result_t))
 
+;RKTWEBVIEW_QT_EXPORT rktwebview_t rkt_webview_tray_create(const char *icon_file, const char *tooltip);
+(define-rktwebview rkt_webview_tray_create
+  (_fun _string/utf-8 _string/utf-8 -> _int))
+
+;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_tray_set_icon( rktwebview_t tray, const char *icon_file);
+(define-rktwebview rkt_webview_tray_set_icon
+  (_fun _int _string/utf-8 -> _rkt_result_t))
+
+;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_tray_set_tooltip(rktwebview_t tray, const char *tooltip);
+(define-rktwebview rkt_webview_tray_set_tooltip
+  (_fun _int _string/utf-8 -> _rkt_result_t))
+
+;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_tray_show_message(rktwebview_t tray, const char *title, const char *message);
+(define-rktwebview rkt_webview_tray_show_message
+  (_fun _int _string/utf-8 _string/utf-8 -> _rkt_result_t))
+
+;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_tray_set_menu(rktwebview_t tray, const char *menu_json);
+(define-rktwebview rkt_webview_tray_set_menu
+  (_fun _int _string/utf-8 -> _rkt_result_t))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Initialize and start library
@@ -840,6 +865,34 @@
     )
   )
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tray specific
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (rkt-webview-tray-create icon-file tooltip evt-callback)
+  (let* ((evt-queue (make-queue))
+         (tray (rkt_webview_tray_create icon-file tooltip))
+         (handle (make-rkt-wv tray evt-queue evt-callback #t (lambda () #t))))
+    (hash-set! evt-cb-hash tray (lambda (evt) (evt-callback handle evt)))
+    (hash-set! rkt-wv-store tray handle)
+    handle))
+
+(define (rkt-webview-tray-set-icon! tray icon-file)
+  (rkt_webview_tray_set_icon (rkt-wv-win tray) icon-file))
+
+(define (rkt-webview-tray-set-tooltip! tray tooltip)
+  (rkt_webview_tray_set_tooltip (rkt-wv-win tray) tooltip))
+
+(define (rkt-webview-tray-show-message tray title message)
+  (rkt_webview_tray_show_message (rkt-wv-win tray) title message))
+
+(define (rkt-webview-tray-set-menu! tray menu-json)
+  (rkt_webview_tray_set_menu (rkt-wv-win tray) menu-json))
+
+;; Furthermore: rkt-webview-close, rkt-webview-valid?, rkt-webview-show and rkt-webview-hide apply also to tray
+
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Administration
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

racket-webview.rkt

@@ -37,6 +37,8 @@
          webview-devtools
          webview-close
 
+         wv-win?
+
          webview-run-js
          webview-call-js
          webview-call-js-result?
@@ -129,6 +131,14 @@
 
          webview-delayed-reactor
 
+         ; tray specific
+         webview-tray-create
+         webview-tray-set-icon!
+         webview-tray-set-tooltip!
+         webview-tray-show-message
+         webview-tray-set-menu!
+         wv-tray?
+
          ;test
          )
 
@@ -187,8 +197,23 @@
   ([handle #:mutable]
    [context #:mutable]
    [window-nr #:mutable]
+   [kind #:mutable]
    )
-  #:transparent)
+  #:transparent
+  )
+
+(define raw-wv-win? wv-win?)
+
+(set! wv-win?
+      (λ (wv)
+        (and (raw-wv-win? wv)
+             (eq? (wv-win-kind wv) 'window))))
+
+(define (wv-tray? wv)
+  (and (raw-wv-win? wv)
+       (eq? (wv-win-kind wv) 'tray)))
+
+
 
 (define re_head #px"[<][/][Hh][eE][aA][dD][>]")
 
@@ -507,7 +532,7 @@
   (->* (wv-context? string? procedure?)
        (#:parent (or/c wv-win? #f))
        wv-win?)
-  (let* ((h (make-wv-win #f context -1))
+  (let* ((h (make-wv-win #f context -1 'window))
          (event-processor (λ (wv evt)
                             (event-callback h (util-parse-event evt))))
          (close-callback (λ () #t))
@@ -606,8 +631,15 @@
        (-> wv-win? symbol?)
        (name-to-wrap (wv-win-handle wv))))))
 
-(def-win-func webview-show rkt-webview-show)
+(define-syntax def-win-tray-func
-(def-win-func webview-hide rkt-webview-hide)
+  (syntax-rules ()
+    ((_ name name-to-wrap)
+     (define/contract (name wv)
+       (-> (or/c wv-win? wv-tray?) symbol?)
+       (name-to-wrap (wv-win-handle wv))))))
+
+(def-win-tray-func webview-show rkt-webview-show)
+(def-win-tray-func webview-hide rkt-webview-hide)
 (def-win-func webview-maximize rkt-webview-maximize)
 (def-win-func webview-minimize rkt-webview-minimize)
 (def-win-func webview-show-normal rkt-webview-show-normal)
@@ -667,7 +699,7 @@
   (rkt-webview-set-icon! (wv-win-handle wv) (format "~a" icon-file)))
 
 (define/contract (webview-close wv)
-  (-> wv-win? symbol?)
+  (-> (or/c wv-win? wv-tray?) symbol?)
   (begin
     (rkt-webview-close (wv-win-handle wv))
     'oke))
@@ -1021,6 +1053,41 @@
 (define (webview-info)
   (rkt-webview-info))
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tray specific
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define/contract (webview-tray-create icon-file event-callback #:tooltip [tooltip ""])
+  (->* ((or/c string? path?) procedure?) (#:tooltip string?) wv-win?)
+  (let* ((h (make-wv-win #f #f -1 'tray))
+         (event-processor
+          (lambda (wv evt)
+            (event-callback h (util-parse-event evt))))
+         (internal-handle
+          (rkt-webview-tray-create (format "~a" icon-file)
+                                   tooltip
+                                   event-processor)))
+    (set-wv-win-handle! h internal-handle)
+    (set-wv-win-window-nr! h (rkt-wv-win internal-handle))
+    h))
+
+(define/contract (webview-tray-set-icon! tray icon-file)
+  (-> wv-tray? (or/c string? path?) symbol?)
+  (rkt-webview-tray-set-icon! tray (format "~a" icon-file)))
+
+(define/contract (webview-tray-set-tooltip! tray tooltip)
+  (-> wv-tray? string? symbol?)
+  (rkt-webview-tray-set-tooltip! tray tooltip))
+
+(define/contract (webview-tray-show-message tray title message)
+  (-> wv-tray? string? string? symbol?)
+  (rkt-webview-tray-show-message tray title message))
+
+(define/contract (webview-tray-set-menu! tray menu)
+  (-> wv-tray? is-wv-menu? symbol?)
+  (rkt-webview-tray-set-menu! tray (wv-menu->json menu)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; delayed reactor
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

wv-tray.rkt

@@ -0,0 +1,112 @@
+#lang racket/base
+
+(require "racket-webview.rkt"
+         "menu.rkt"
+         racket/class)
+
+(provide wv-tray%)
+
+(define wv-tray%
+  (class object%
+
+    (init-field [icon (error "tray icon is mandatory")]
+                [tooltip ""]
+                [menu #f])
+
+    (define wv #f)
+    (define menu-callbacks (make-hash))
+
+    (define/private (event-handler wv evt)
+      (let ((event (hash-ref evt 'event 'unknown-event)))
+        (cond
+          [(eq? event 'tray-activated)
+           (send this activated (hash-ref evt 'reason 'unknown))]
+
+          [(eq? event 'tray-message-clicked)
+           (send this message-clicked)]
+
+          [(eq? event 'tray-menu-item-chosen)
+           (let* ((id (string->symbol
+                       (format "~a" (hash-ref evt 'id 'unknown))))
+                  (cb (hash-ref menu-callbacks id #f)))
+             (if cb
+                 (cb)
+                 (send this menu-item-chosen id)))]
+
+          [else
+           (send this unhandled-event evt)])))
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; Events
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define/public (activated reason)
+      #t)
+
+    (define/public (message-clicked)
+      #t)
+
+    (define/public (menu-item-chosen id)
+      #t)
+
+    (define/public (unhandled-event evt)
+      #t)
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; Commands
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define/public (show)
+      (webview-show wv)
+      this)
+
+    (define/public (hide)
+      (webview-hide wv)
+      this)
+
+    (define/public (close)
+      (webview-close wv)
+      this)
+
+    (define/public (set-icon! icon-file)
+      (webview-tray-set-icon! wv icon-file)
+      this)
+
+    (define/public (set-tooltip! text)
+      (webview-tray-set-tooltip! wv text)
+      this)
+
+    (define/public (show-message title message)
+      (webview-tray-show-message wv title message)
+      this)
+
+    (define/public (set-menu! menu-def)
+      (hash-clear! menu-callbacks)
+      (wv-menu-for-each menu-def
+                        (lambda (item)
+                          (let ((id (wv-menu-item-id item))
+                                (cb (wv-menu-item-callback item)))
+                            (when cb
+                              (hash-set! menu-callbacks id cb)))))
+      (webview-tray-set-menu! wv menu-def)
+      this)
+
+    (define/public (connect-menu! id callback)
+      (hash-set! menu-callbacks id callback)
+      this)
+
+    (define/public (disconnect-menu! id)
+      (hash-remove! menu-callbacks id)
+      this)
+
+    (define/public (handle)
+      wv)
+
+    (super-new)
+
+    (set! wv (webview-tray-create icon (λ (wv evt)
+                                         (send this event-handler wv evt))
+                                  #:tooltip tooltip))
+
+    (unless (eq? menu #f)
+      (send this set-menu! menu))))