hans/web-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

New backend with ffi.

Browse Source
This commit is contained in:
Hans Dijkema
2025-09-24 09:08:23 +02:00
parent 12e9d3ad94
commit 79d00df746
5 changed files with 887 additions and 736 deletions
Download Patch File Download Diff File Expand all files Collapse all files

150
private/menu.rkt Normal file
View File

@@ -0,0 +1,150 @@
(module menu racket/base
(require json)
(provide menu
menu-item
is-menu?
menu-set-callback!
menu-set-icon!
menu-set-title!
menu->json
with-menu-item
)
(define-struct ww-menu-item
(id [title #:mutable] [icon-file #:mutable] [callback #:mutable] [submenu #:mutable] [separator #:mutable])
#:transparent)
(define-struct ww-menu
([items #:mutable])
#:transparent
)
(define (is-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)
(f (cdr m))
(and (is-menu? (ww-menu-item-submenu (car m)))
(f (cdr m))))
#f)
))
))
(f (ww-menu-items mnu)))
#f)
#f))
(define (menu . items)
(make-ww-menu items))
(define (menu-item id title
#:icon-file [icon-file #f]
#:callback [callback (lambda args #t)]
#:submenu [submenu #f]
#:separator [separator #f])
(unless (symbol? id)
(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))
(error "menu-item's optional argument icon-file must be #f, string? or path?"))
(unless (or (eq? submenu #f) (is-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))
(define (menu->hash menu)
(unless (is-menu? menu)
(error "menu->hash must be called with a 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))))
(unless (eq? (ww-menu-item-separator item) #f)
(hash-set! h 'separator #t))
h
)) items))
)
(let ((h (make-hasheq)))
(hash-set! h 'menu r)
h)))
(define (menu->json menu)
(let ((o (open-output-string)))
(write-json (menu->hash menu) o)
(get-output-string o)))
(define (find-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)
item
(let ((submenu (ww-menu-item-submenu item)))
(if (eq? submenu #f)
(f (cdr items))
(let ((found-item (find-menu-item submenu id)))
(if (eq? found-item #f)
(f (cdr items))
found-item))
))
))
))
))
(f items))))
(define (with-menu-item menu id cb)
(unless (is-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)))
(if (eq? item #f)
(error (format "cannot find id'~a in given menu" id))
(cb item)))
menu)
(define (menu-set-title! menu id title)
(unless (string? title)
(error "title must be of string?"))
(with-menu-item menu id
(λ (item)
(set-ww-menu-item-title! item title))))
(define (menu-set-icon! menu id icon)
(unless (or (eq? icon #f) (path? icon) (string? icon))
(error "title must be of #f, string? or path?"))
(with-menu-item menu id
(λ (item)
(set-ww-menu-item-icon-file! item icon))))
(define (menu-set-callback! menu id cb)
(unless (procedure? cb)
(error "callback must be of procedure?"))
(with-menu-item menu id
(λ (item)
(set-ww-menu-item-callback! item cb))))
); end of module

125
private/web-racket.rkt
View File

@@ -3,11 +3,13 @@
(require racket/gui
"web-wire.rkt"
"css.rkt"
"menu.rkt"
"../utils/sprintf.rkt"
html-printer
(prefix-in g: gregor)
(prefix-in g: gregor/time)
gregor-utils
net/sendurl
)
(provide ww-element%
@@ -70,12 +72,13 @@
id)
(define/public (win)
(let ((w (hash-ref windows win-id #f)))
(let ((w (hash-ref windows (ww-win-id win-id) #f)))
w))
(define connected-callbacks (make-hash))
(define/public (callback evt . args)
(ww-debug (format "Callback for ~a - ~a - ~a" id evt args))
(let ((cb (hash-ref connected-callbacks evt #f)))
(unless (eq? cb #f)
(with-handlers ([exn:fail?
@@ -193,7 +196,11 @@
(inp-set! val (ww-get-value (send this get-win-id)
(send this get-id)))
(send this connect 'input (λ (data)
(inp-set! val (hash-ref data 'value))))
(ww-debug data)
(let ((js-evt (hash-ref data 'js-evt #f)))
(unless (eq? js-evt #f)
(when (hash-has-key? js-evt 'value)
(inp-set! val (hash-ref js-evt 'value)))))))
(send (send this win) bind 'input (format "#~a" (send this get-id)))
)
))
@@ -280,6 +287,7 @@
(class object%
(init-field [profile 'default-profile]
[use-browser #t]
[parent-id #f]
[parent #f]
[title "Racket HTML Window"]
@@ -296,37 +304,43 @@
(define menu-cbs (make-hash))
(define elements (make-hash))
(define html-handle #f)
(define (event-handler type evt content)
(ww-debug (format "win-id=~a '~a '~a ~a" win-id type evt content))
(define (event-handler evt content)
(ww-debug (format "win-id=~a '~a ~a" win-id evt content))
(cond
([eq? evt 'page-loaded] (send this html-loaded))
([eq? evt 'click] (handle-click (car content) (cadr content)))
([eq? evt 'input] (handle-input (car content) (cadr content)))
([eq? evt 'change] (handle-change (car content) (cadr content)))
([eq? evt 'resized] (let* ((m (regexp-match re-resize content))
(width* (string->number (cadr m)))
(height* (string->number (caddr m)))
([eq? evt 'page-loaded] (let ((page-handle (hash-ref content 'page_handle 'none)))
(ww-debug (format "html-handle: ~a, page-handle: ~a, equal?: ~a"
html-handle
page-handle
(equal? html-handle page-handle)))
(when (and (number? html-handle) (number? page-handle) (= html-handle page-handle))
(send this html-loaded))))
([eq? evt 'click] (handle-click (string->symbol (hash-ref content 'id)) content))
([eq? evt 'input] (handle-input (string->symbol (hash-ref content 'id)) content))
([eq? evt 'change] (handle-change (string->symbol (hash-ref content 'id)) content))
([eq? evt 'resized] (let* ((width* (hash-ref content 'width))
(height* (hash-ref content 'height))
)
(set! width width*)
(set! height height*)))
([eq? evt 'moved] (let* ((m (regexp-match re-move content))
(x* (string->number (cadr m)))
(y* (string->number (caddr m)))
([eq? evt 'moved] (let* ((x* (hash-ref content 'x))
(y* (hash-ref content 'y))
)
(set! x x*)
(set! y y*)
))
([eq? evt 'request-close] (when (send this can-close?)
(send this close)))
([eq? evt 'menu-item-choosen] (let* ((menu-id (string->symbol content))
([eq? evt 'menu-item-choosen] (let* ((menu-id (string->symbol (hash-ref content 'item)))
(cb (hash-ref menu-cbs menu-id #f)))
(unless (eq? cb #f)
(cb))))
([eq? evt 'navigate] (let* ((m (regexp-match re-navigate content))
(url (ww-from-string (cadr m)))
(type (string->symbol (caddr m)))
(kind (string->symbol (cadddr m)))
([eq? evt 'navigate] (let* ((url (hash-ref content 'url))
(kind (string->symbol (hash-ref content
'navigation-kind)))
(type (string->symbol (hash-ref content
'navigation-type)))
)
(send this handle-navigate url type kind)))
)
@@ -335,12 +349,13 @@
(define/public (handle-click element-id data)
(let ((el (hash-ref elements element-id #f)))
(unless (eq? el #f)
(ww-debug (format "CALLING CALLBACK FOR ~a" element-id))
(send el callback 'click data))))
(define/public (handle-change element-id data)
(let ((el (hash-ref elements element-id #f)))
(unless (eq? el #f)
(send el callback 'change (hash-ref data 'value)))))
(send el callback 'change data 'value))))
(define/public (handle-input element-id data)
(let ((el (hash-ref elements element-id #f)))
@@ -350,7 +365,7 @@
(define/public (handle-navigate url type kind)
(let ((method (if (eq? kind 'set-html) 'set-html-file! 'set-url)))
(cond
([eq? type 'link-clicked]
([eq? type 'standard]
(dynamic-send this method url))
(else (ww-error (format "Don't know what to do for ~a - ~a" type url)))
)
@@ -435,12 +450,15 @@
(define/public (get-title)
title)
(define/public (set-icon! icn)
(ww-set-icon win-id icn))
(define/public (set-html-file! file)
(set! html-file file)
(ww-set-html win-id html-file))
(set! html-handle (ww-set-html win-id html-file)))
(define/public (set-url url)
(ww-set-url win-id url))
(send-url url))
(define/public (html-loaded)
(send this bind-buttons)
@@ -468,23 +486,23 @@
(ww-set-show-state win-id 'fullscreen))
(define/public (show-state)
(ww-show-state win-id))
(ww-get-show-state win-id))
(define/public (can-close?)
#t)
(define/public (close)
(ww-close win-id)
(hash-remove! windows win-id)
(hash-remove! windows-evt-handlers win-id)
(hash-remove! windows (ww-win-id win-id))
(hash-remove! windows-evt-handlers (ww-win-id win-id))
(when (= (hash-count windows) 0)
(ww-stop))
)
(define/public (set-menu menu-def)
(define/public (set-menu! menu-def)
(ww-set-menu win-id menu-def))
(define/public (connect-menu id cb)
(define/public (connect-menu! id cb)
(hash-set! menu-cbs id cb))
; files and directories
@@ -534,7 +552,10 @@
)
)
)
; Supers first
(super-new)
; construct
(begin
(when (= (hash-count windows) 0)
@@ -550,29 +571,31 @@
(next-window-init-position)
(set! win-id (ww-new profile parent-id))
(set! win-id
(if (eq? parent-id #f)
(ww-new profile use-browser)
(ww-new profile use-browser parent-id)))
(when (eq? win-id #f)
(error "Window could not be constructed"))
(hash-set! windows-evt-handlers win-id event-handler)
(hash-set! windows win-id this)
(hash-set! windows-evt-handlers (ww-win-id win-id) event-handler)
(hash-set! windows (ww-win-id win-id) this)
(ww-move win-id x y)
(ww-resize win-id width height)
(ww-set-title win-id title)
(send this set-title! title)
(unless (eq? icon #f)
(ww-set-icon win-id icon))
(send this set-icon! icon))
(unless (eq? menu #f)
(ww-set-menu win-id menu))
(send this set-menu! menu))
(unless (eq? html-file #f)
(ww-set-html win-id html-file))
(send this set-html-file! html-file))
)
(super-new)
))
(define (set-global-stylesheet st)
@@ -587,11 +610,18 @@
;; Testing stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test-menu
'(("File" (("Open" open) ("Close" close) ("Quit" quit)))
("Edit" (("Copy" copy) ("Advanced" (("Copy 1" copy1) ("Copy 2" copy2)))
("Cut" cut) ("Paste" paste)))
))
(define test-menu (menu (menu-item 'm-file "File"
#:submenu
(menu (menu-item 'm-open "Open File")
(menu-item 'm-close "Close File")
(menu-item 'm-quit "Quit" #:separator #t)))
(menu-item 'm-edit "Edit"
#:submenu
(menu (menu-item 'm-copy "Copy")
(menu-item 'm-cut "Cut")
(menu-item 'm-paste "Paste")
(menu-item 'm-prefs "Preferences" #:separator #t)
))))
(define test-dialog%
(class ww-window%
@@ -601,6 +631,7 @@
(define/override (html-loaded)
(super html-loaded)
(ww-debug "html-loaded for test-dialog%")
(let* ((btn (send this element 'ok-btn)))
(send btn connect 'click (λ (data)
(send this close)))))
@@ -611,15 +642,17 @@
(super-new [html-file "../../web-wire/test/test1.html"])
(define/override (html-loaded)
(ww-debug "HTML LOADED")
(super html-loaded)
(let* ((btn (send this element 'app-button)))
(send btn connect 'click (λ (data)
(new test-dialog% [parent this]))))
)
(new test-dialog% [parent this]))))
(ww-debug "SETTING MENU")
(send this set-menu! test-menu)
(send this connect-menu! 'm-quit (λ () (send this close)))
)
(begin
(send this set-menu test-menu)
(send this connect-menu 'quit (λ () (send this close)))
)
)
)

1218
private/web-wire.rkt
View File

File diff suppressed because it is too large Load Diff

116
private/webui-wire-ffi.rkt
View File

@@ -5,14 +5,19 @@
ffi/unsafe/atomic
setup/dirs
"../utils/utils.rkt"
(prefix-in g: racket/gui)
(rename-in racket/gui
(-> %->))
data/queue
)
(provide webwire-new
webwire-current
webwire-id
webwire-destroy
webwire-command
webwire-items
webwire-items-available
webwire-handlers!
webwire-get
webwire-status
webwire-status->string
@@ -81,8 +86,8 @@
#:c-id webwire_destroy)
(define-libwebui-wire webwire-command
(_fun _webui-handle/null _string/utf-8
-> [r : _string/utf-8]
(_fun _webui-handle/null _string*/utf-8
-> [r : _string*/utf-8]
-> r
)
#:c-id webwire_command)
@@ -93,9 +98,9 @@
(define-libwebui-wire webwire-get
(_fun _webui-handle/null
[evt : (_ptr o _string/utf-8)]
[kind : (_ptr o _string/utf-8)]
[msg : (_ptr o _string/utf-8)]
[evt : (_ptr o _string*/utf-8)]
[kind : (_ptr o _string*/utf-8)]
[msg : (_ptr o _string*/utf-8)]
-> [ result : _webui-get-result ]
-> (list result
evt
@@ -104,19 +109,28 @@
)
#:c-id webwire_get)
#|
(if (eq? evt #f)
#f
(cast evt _pointer _string/utf-8))
(if (eq? kind #f)
#f
(string->symbol
(cast kind _pointer _string/utf-8)))
(if (eq? msg #f)
#f
(cast msg _pointer _string/utf-8))
)
|#
(define-libwebui-wire webwire-id
(_fun _webui-handle/null
-> _int)
#:c-id webwire_handle_id)
(define my-count 0)
(define last-queue-count -1)
(define (f c) (set! my-count (+ my-count 1)) (set! last-queue-count c))
(define (appl thunk)
(thunk))
(define-libwebui-wire webwire-items-available
(_fun _webui-handle/null (_cprocedure (list _int) _void #:async-apply appl) -> _void)
#:c-id webwire_set_signaller)
(define-libwebui-wire webwire-handlers!
(_fun _webui-handle/null
(_fun #:async-apply appl _bytes/nul-terminated -> _void)
(_fun #:async-apply appl _bytes/nul-terminated _bytes/nul-terminated -> _void)
-> _bool)
#:c-id webwire_set_handlers)
(define-libwebui-wire webwire-status
(_fun _webui-handle/null -> _webui-handle-status)
@@ -125,7 +139,7 @@
(define-libwebui-wire webwire-status->string
(_fun _webui-handle-status
-> (r : _string/utf-8)
-> (r : _string*/utf-8)
-> r)
#:c-id webwire_status_string)
@@ -181,3 +195,65 @@
(f))))))
(f)))))
(define evt-fifo (make-queue))
(define log-fifo (make-queue))
(define (qthread)
(parameterize ([current-eventspace (current-eventspace)])
(thread
(lambda ()
(letrec ((f (lambda ()
(if (> (queue-length evt-fifo) 0)
(let ((e (dequeue! evt-fifo)))
(queue-callback (lambda ()
(display e)
(display " - ")
(displayln (current-thread))))
(yield)
(f))
(begin
;(displayln 'sleeping)
(sleep 0.005)
(f))))))
(f))))
))
;(define (h-evt evt)
; (enqueue! evt-fifo evt))
(define ce (current-eventspace))
(define h-evt (parameterize ([current-eventspace ce])
(lambda (evt)
(queue-callback (lambda ()
(enqueue! evt-fifo
(list evt (current-thread)))))
(yield)))
)
(define h-log (parameterize ([current-eventspace ce])
(lambda (kind msg)
(queue-callback (lambda ()
(enqueue! log-fifo
(list kind msg (current-thread)))))
(yield)))
)
; (enqueue! log-fifo (list kind msg (current-thread))))
(define (h-ffi-evt evt)
(h-evt evt))
; (parameterize ([g:current-eventspace (g:current-eventspace)])
; (lambda (evt)
; (g:queue-callback (lambda () (h-evt evt))))))
(define (h-ffi-log kind msg)
(h-log kind msg))
; (parameterize ([g:current-eventspace (g:current-eventspace)])
; (lambda (kind msg)
; (g:queue-callback (lambda () (h-log kind msg))))))