documentation

2026-04-01 16:23:56 +02:00
parent 5ee62d0064
commit ab666368b1
27 changed files with 1080 additions and 164 deletions
--- a/private/lib/linux/x86_64/librktwebview.so
+++ b/private/lib/linux/x86_64/librktwebview.so
--- a/private/lib/linux/x86_64/rktwebview_prg
+++ b/private/lib/linux/x86_64/rktwebview_prg
--- a/private/menu.rkt
+++ b/private/menu.rkt
@@ -1,60 +1,72 @@
 (module menu racket/base

-  (require json)
+  (require json
+           net/url)
  
-  (provide menu
-           menu-item
-           is-menu?
-           menu-set-callback!
-           menu-set-icon!
-           menu-set-title!
-           menu->json
-           with-menu-item
-           menu-for-each
-           ww-menu-item-callback
-           ww-menu-item-id
-           ww-menu-id
+  (provide wv-menu
+           wv-menu-item
+           is-wv-menu?
+           wv-menu-set-callback!
+           wv-menu-set-icon!
+           wv-menu-set-title!
+           wv-menu->json
+           with-wv-menu-item
+           wv-menu-for-each
+           wv-menu-item-callback
+           wv-menu-item-id
+           wv-menu-id
           )


-  (define-struct ww-menu-item
-    (id [title #:mutable] [icon-file #:mutable] [callback #:mutable] [submenu #:mutable] [separator #:mutable])
+  
+  (define-struct ww-menu-item*
+    (id [title #:mutable] [icon-url #:mutable] [callback #:mutable] [submenu #:mutable] [separator #:mutable])
    #:transparent)
  
-  (define-struct ww-menu
+  (define-struct ww-menu*
    (id [items #:mutable])
    #:transparent
    )

-  (define (is-menu? mnu)
-    (if (ww-menu? mnu)
-        (if (list? (ww-menu-items mnu))
+
+  (define (wv-menu-item-callback mi)
+    (ww-menu-item*-callback mi))
+
+  (define (wv-menu-item-id mi)
+    (ww-menu-item*-id mi))
+
+  (define (wv-menu-id m)
+    (ww-menu*-id m))
+  
+  (define (is-wv-menu? mnu)
+    (if (ww-menu*? mnu)
+        (if (list? (ww-menu*-items mnu))
            (letrec ((f (lambda (m)
                          (if (null? m)
                              #t
-                              (if (ww-menu-item? (car m))
-                                  (if (eq? (ww-menu-item-submenu (car m)) #f)
+                              (if (ww-menu-item*? (car m))
+                                  (if (eq? (ww-menu-item*-submenu (car m)) #f)
                                      (f (cdr m))
-                                      (and (is-menu? (ww-menu-item-submenu (car m)))
+                                      (and (is-wv-menu? (ww-menu-item*-submenu (car m)))
                                           (f (cdr m))))
                                  #f)
                              ))
                        ))
-              (f (ww-menu-items mnu)))
+              (f (ww-menu*-items mnu)))
            #f)
        #f))

-  (define (menu . items)
+  (define (wv-menu . items)
    (let ((menu-id #f))
      (when (symbol? (car items))
        (set! menu-id (car items))
        (set! items (cdr items)))
      (when (list? (car items))
        (set! items (car items)))
-      (make-ww-menu menu-id items)))
+      (make-ww-menu* menu-id items)))

-  (define (menu-item id title
-                     #:icon-file [icon-file #f]
+  (define (wv-menu-item id title
+                     #:icon-url [icon-url #f]
                     #:callback [callback (lambda args #t)]
                     #:submenu [submenu #f]
                     #:separator [separator #f])
@@ -62,47 +74,49 @@
      (error "menu-item needs an id of symbol?"))
    (unless (string? title)
      (error "menu-item needs a title of string?"))
-    (unless (or (eq? icon-file #f) (string? icon-file) (path? icon-file))
+    (unless (or (eq? icon-url #f) (string? icon-url) (url? icon-url))
      (error "menu-item's optional argument icon-file must be #f,  string? or path?"))
-    (unless (or (eq? submenu #f) (is-menu? submenu))
+    (unless (or (eq? submenu #f) (is-wv-menu? submenu))
      (error "menu-item's optional argument submenu must be #f or is-menu?"))
    (unless (boolean? separator)
      (error "menu-item's optional argument separator must be boolean?"))
-    (make-ww-menu-item id title icon-file callback submenu separator))
+    (let ((u (if (url? icon-url) (url->string icon-url) icon-url)))
+      (make-ww-menu-item* id title u callback submenu separator))
+    )

-  (define (menu->hash menu . for-json)
+  (define (wv-menu->hash menu . for-json)
    (let ((fj (if (null? for-json) #f (car for-json))))
-      (unless (is-menu? menu)
+      (unless (is-wv-menu? menu)
        (error "menu->hash must be called with a menu"))
-      (let* ((items (ww-menu-items menu))
+      (let* ((items (ww-menu*-items menu))
             (r (map (λ (item)
                       (let ((h (make-hasheq)))
-                         (hash-set! h 'id (format "~a" (ww-menu-item-id item)))
-                         (hash-set! h 'name (ww-menu-item-title item))
-                         (unless (eq? (ww-menu-item-icon-file item) #f)
-                           (hash-set! h 'icon (ww-menu-item-icon-file item)))
-                         (unless (eq? (ww-menu-item-submenu item) #f)
-                           (hash-set! h 'submenu (menu->hash (ww-menu-item-submenu item) fj)))
-                         (unless (eq? (ww-menu-item-separator item) #f)
+                         (hash-set! h 'id (format "~a" (ww-menu-item*-id item)))
+                         (hash-set! h 'name (ww-menu-item*-title item))
+                         (unless (eq? (ww-menu-item*-icon-url item) #f)
+                           (hash-set! h 'icon (ww-menu-item*-icon-url item)))
+                         (unless (eq? (ww-menu-item*-submenu item) #f)
+                           (hash-set! h 'submenu (wv-menu->hash (ww-menu-item*-submenu item) fj)))
+                         (unless (eq? (ww-menu-item*-separator item) #f)
                           (hash-set! h 'separator #t))
                         h
                         )) items))
             )
        (let ((h (make-hasheq)))
          (hash-set! h 'menu r)
-          (hash-set! h 'id (if fj (format "~a" (ww-menu-id menu)) (ww-menu-id menu)))
+          (hash-set! h 'id (if fj (format "~a" (ww-menu*-id menu)) (ww-menu*-id menu)))
          h))))

-  (define (menu-for-each menu cb)
-    (let ((items (ww-menu-items menu)))
+  (define (wv-menu-for-each menu cb)
+    (let ((items (ww-menu*-items menu)))
      (letrec ((f (λ (items)
                    (if (null? items)
                        #t
                        (let ((item (car items)))
-                          (let ((submenu (ww-menu-item-submenu item)))
+                          (let ((submenu (ww-menu-item*-submenu item)))
                            (if (eq? submenu #f)
                                (cb item)
-                                (menu-for-each submenu cb)))
+                                (wv-menu-for-each submenu cb)))
                          (f (cdr items))
                          )
                        )
@@ -110,23 +124,23 @@
                  ))
        (f items))))

-  (define (menu->json menu)
+  (define (wv-menu->json menu)
    (let ((o (open-output-string)))
-      (write-json (menu->hash menu #t) o)
+      (write-json (wv-menu->hash menu #t) o)
      (get-output-string o)))

-  (define (find-menu-item menu id)
-    (let ((items (ww-menu-items menu)))
+  (define (find-wv-menu-item menu id)
+    (let ((items (ww-menu*-items menu)))
      (letrec ((f (λ (items)
                    (if (null? items)
                        #f
                        (let ((item (car items)))
-                          (if (eq? (ww-menu-item-id item) id)
+                          (if (eq? (ww-menu-item*-id item) id)
                              item
-                              (let ((submenu (ww-menu-item-submenu item)))
+                              (let ((submenu (ww-menu-item*-submenu item)))
                                (if (eq? submenu #f)
                                    (f (cdr items))
-                                    (let ((found-item (find-menu-item submenu id)))
+                                    (let ((found-item (find-wv-menu-item submenu id)))
                                      (if (eq? found-item #f)
                                          (f (cdr items))
                                          found-item))
@@ -136,37 +150,38 @@
                  ))
        (f items))))

-  (define (with-menu-item menu id cb)
-    (unless (is-menu? menu)
+  (define (with-wv-menu-item menu id cb)
+    (unless (is-wv-menu? menu)
      (error "menu must be of is-menu?"))
    (unless (symbol? id)
      (error "id must be of symbol?"))
-    (let ((item (find-menu-item menu id)))
+    (let ((item (find-wv-menu-item menu id)))
      (if (eq? item #f)
          (error (format "cannot find id'~a in given menu" id))
          (cb item)))
    menu)
      
-  (define (menu-set-title! menu id title)
+  (define (wv-menu-set-title! menu id title)
    (unless (string? title)
      (error "title must be of string?"))
-    (with-menu-item menu id
+    (with-wv-menu-item menu id
      (λ (item)
-        (set-ww-menu-item-title! item title))))
+        (set-ww-menu-item*-title! item title))))
  
-  (define (menu-set-icon! menu id icon)
-    (unless (or (eq? icon #f) (path? icon) (string? icon))
+  (define (wv-menu-set-icon! menu id icon-url)
+    (unless (or (eq? icon-url #f) (url? icon-url) (string? icon-url))
      (error "title must be of #f, string? or path?"))
-    (with-menu-item menu id
+    (with-wv-menu-item menu id
      (λ (item)
-        (set-ww-menu-item-icon-file! item icon))))
+        (let ((u (if (url? icon-url) (url->string icon-url) icon-url)))
+          (set-ww-menu-item*-icon-url! item u)))))

-  (define (menu-set-callback! menu id cb)
+  (define (wv-menu-set-callback! menu id cb)
    (unless (procedure? cb)
      (error "callback must be of procedure?"))
-    (with-menu-item menu id
+    (with-wv-menu-item menu id
      (λ (item)
-        (set-ww-menu-item-callback! item cb))))
+        (set-ww-menu-item*-callback! item cb))))
          
  ); end of module

--- a/private/racket-webview-qt.rkt
+++ b/private/racket-webview-qt.rkt
@@ -590,7 +590,7 @@
 ;                                      )))))
      (let ((handle (make-rkt-wv wv evt-queue evt-callback #t close-callback)))
        (thread (λ ()
-                  (sleep 1)
+                  (sleep 0.01)
                  (letrec ((f (λ ()
                              (let ((r (rkt-process-events handle)))
                                (if (eq? r 'quit)
--- a/private/racket-webview-version.rkt
+++ b/private/racket-webview-version.rkt
@@ -7,5 +7,5 @@

 (define webview-major 0)
 (define webview-minor 1)
-(define webview-patch 0)
+(define webview-patch 1)

--- a/private/racket-webview.rkt
+++ b/private/racket-webview.rkt
@@ -5,6 +5,7 @@
         "utils.rkt"
         "mimetypes.rkt"
         "rgba.rkt"
+         "menu.rkt"
         finalizer
         racket/async-channel
         web-server/http
@@ -73,6 +74,8 @@
         webview-set-html!
         webview-base-url

+         webview-set-menu!
+
         webview-set-innerHTML!
         
         webview-set-value!
@@ -105,6 +108,7 @@
         
         webview-standard-file-getter
         webview-default-boilerplate-js
+         webview-default-boilerplate-css

         webview-version
         webview-info
@@ -123,16 +127,38 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 (define-runtime-path js-path "../js")
+(define-runtime-path css-path "../js")

 (define (webview-default-boilerplate-js . custom-js)
-  (let ((file (build-path js-path "boilerplate.js")))
-    (let ((bjs (file->string file)))
+  (let ((file (build-path js-path "boilerplate.js"))
+        (menu-js-file (build-path js-path "menu.js")))
+    (let ((bjs (file->string file))
+          (mjs (file->string menu-js-file))
+          )
      (let ((js (string-append bjs
+                               mjs
                               (if (null? custom-js)
                                   ""
                                   ((car custom-js))))))
        js))))

+(define (webview-default-boilerplate-css . custom-css)
+  (let ((file (build-path css-path "boilerplate.css"))
+        (menu-css-file (build-path css-path "menu.css")))
+    (let ((bcss (file->string file))
+          (mcss (file->string menu-css-file))
+          )
+      (let ((css (string-append bcss
+                                mcss
+                                (if (null? custom-css)
+                                    ""
+                                    ((car custom-css)))
+                                )
+                 )
+            )
+        css))))
+
+
 (define-struct wv-context
  ([context #:mutable]
   [port #:mutable]
@@ -142,6 +168,7 @@
   [request-count #:mutable]
   [sec-token-cache #:mutable]
   [cert-ou-token #:mutable]
+   [boilerplate-css #:mutable]
   )
  #:transparent
  )
@@ -153,16 +180,16 @@
   )
  #:transparent)

+(define re_head #px"[<][/][Hh][eE][aA][dD][>]")
+
 (define (process-html context path out)
  (let ((html (file->string path)))
-    (display html out)))
-;        (boilerplate-js ((wv-context-boilerplate-js wv-win-handle))))
-;    (set! html (string-replace html "<head>"
-;                               (string-append "<head>" "\n"
-;                                              "<script>" "\n"
-;                                              boilerplate-js "\n"
-;                                              "</script>" "\n")))
-;    (display html out)))
+    (let ((html* (regexp-replace re_head html 
+                                 (string-append "<style>\n"
+                                                (wv-context-boilerplate-css context)
+                                                "\n</style>\n"
+                                                "</head>"))))
+      (display html* out))))

 (define (process-file context ext path out)
  (let ((content (file->bytes path)))
@@ -414,11 +441,13 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 (define/contract (webview-new-context file-getter
-                                      #:boilerplate-js [bj (webview-default-boilerplate-js)])
-  (->* (procedure?) (#:boilerplate-js string?) wv-context?)
+                                      #:boilerplate-js [bj (webview-default-boilerplate-js)]
+                                      #:boilerplate-css [bc (webview-default-boilerplate-css)])
+  (->* (procedure?) (#:boilerplate-js string? #:boilerplate-css string?) wv-context?)
  (let* ((h (make-wv-context 0 0 file-getter #f #f 0
                             (make-lru 250 #:cmp eq?)
                             (symbol->string (make-security-token))
+                             bc
                             ))
         (cert (generate-self-signed-cert 2048 365 '("127.0.0.1" "localhost")
                                          "NL" "Dijkema"
@@ -497,6 +526,17 @@
      )
  )

+(define/contract (webview-set-menu! wv menu)
+  (-> wv-win? is-wv-menu? symbol?)
+  (let* ((json (wv-menu->json menu))
+         (js (string-append "window._web_wire_menu('"
+                            json
+                            "');"))
+         )
+    (webview-run-js wv js)
+    )
+  )
+
 (define (loglevel? x)
  (and (symbol? x)
       (or (eq? x 'error) (eq? x 'info) (eq? x 'debug) (eq? x 'warning))))
--- a/private/wv-context.rkt
+++ b/private/wv-context.rkt
@@ -13,7 +13,9 @@
     base-path
     [file-getter (webview-standard-file-getter base-path)]
     [context-js  (λ () "")]
+     [context-css (λ () "")]
     [boilerplate-js (webview-default-boilerplate-js context-js)]
+     [boilerplate-css (webview-default-boilerplate-css context-css)]
     [ini (error "You need to provide a 'ini' file settings interface for settings, e.g. simple-ini/class")]
     )
     
@@ -35,7 +37,8 @@
    (begin
      (set! wv-context
            (webview-new-context file-getter
-                                 #:boilerplate-js boilerplate-js))
+                                 #:boilerplate-js boilerplate-js
+                                 #:boilerplate-css boilerplate-css))
      (set! settings-obj (new wv-settings% [ini ini] [wv-context 'global]))
      )
    )
--- a/private/wv-dialog.rkt
+++ b/private/wv-dialog.rkt
@@ -38,9 +38,9 @@
            (let ((x (inexact->exact (round (exact->inexact (+ px xx)))))
                  (y (inexact->exact (round (exact->inexact (+ py yy)))))
                  )
-              (displayln "move")
+              (displayln (format "move ~a ~a" x y))
              (send this move x y)
-              (displayln "resize")
+              (displayln (format "resize ~a ~a" x y))
              (send this resize dw dh)
              )
            )
--- a/private/wv-window.rkt
+++ b/private/wv-window.rkt
@@ -145,6 +145,7 @@
    (define (event-handler wv evt)
      (let ((event (hash-ref evt 'event 'unknown-event))
            )
+        (displayln evt)
        (cond
        ((eq? event 'resize)
         (send this resized (hash-ref evt 'w) (hash-ref evt 'h)))
@@ -163,7 +164,7 @@
         (let* ((je (hash-copy (hash-ref evt 'js-evt)))
                (e (make-hash)))
           (hash-set! e 'evt (string->symbol (hash-ref je 'evt)))
-           (hash-set! e 'id (string->symbol (hash-ref je 'id #f)))
+           (hash-set! e 'id (string->symbol (hash-ref je 'id "nil")))
           (hash-set! e 'data (hash-ref je 'js_evt (make-hash)))
           (hash-set! e 'event 'js-evt)
           (when (eq? (send this js-event e) 'wv-unhandled-js-event)
@@ -244,7 +245,6 @@
            )
        )
      )
-            

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; Commands
@@ -257,6 +257,15 @@
    (define/public (remove-class! selector-or-id cl)
      (webview-remove-class! wv selector-or-id cl)
      this)
+
+    (define/public (set-menu! menu)
+      (webview-set-menu! wv menu)
+      this)
+
+    (define/public (connect-menu! id callback)
+      (send this bind! (string->symbol (format "~a" id)) 'menu-item-choosen
+            (λ (el evt data)
+              (callback))))
    
    (define/public (devtools)
      (webview-devtools wv)