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

14
example1/example.rkt
View File

@@ -1 +1,15 @@
#lang racket/gui #lang racket/gui
(define m (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)
))))

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 (require racket/gui
"web-wire.rkt" "web-wire.rkt"
"css.rkt" "css.rkt"
"menu.rkt"
"../utils/sprintf.rkt" "../utils/sprintf.rkt"
html-printer html-printer
(prefix-in g: gregor) (prefix-in g: gregor)
(prefix-in g: gregor/time) (prefix-in g: gregor/time)
gregor-utils gregor-utils
net/sendurl
) )
(provide ww-element% (provide ww-element%
@@ -70,12 +72,13 @@
id) id)
(define/public (win) (define/public (win)
(let ((w (hash-ref windows win-id #f))) (let ((w (hash-ref windows (ww-win-id win-id) #f)))
w)) w))
(define connected-callbacks (make-hash)) (define connected-callbacks (make-hash))
(define/public (callback evt . args) (define/public (callback evt . args)
(ww-debug (format "Callback for ~a - ~a - ~a" id evt args))
(let ((cb (hash-ref connected-callbacks evt #f))) (let ((cb (hash-ref connected-callbacks evt #f)))
(unless (eq? cb #f) (unless (eq? cb #f)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
@@ -193,7 +196,11 @@
(inp-set! val (ww-get-value (send this get-win-id) (inp-set! val (ww-get-value (send this get-win-id)
(send this get-id))) (send this get-id)))
(send this connect 'input (λ (data) (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))) (send (send this win) bind 'input (format "#~a" (send this get-id)))
) )
)) ))
@@ -280,6 +287,7 @@
(class object% (class object%
(init-field [profile 'default-profile] (init-field [profile 'default-profile]
[use-browser #t]
[parent-id #f] [parent-id #f]
[parent #f] [parent #f]
[title "Racket HTML Window"] [title "Racket HTML Window"]
@@ -296,37 +304,43 @@
(define menu-cbs (make-hash)) (define menu-cbs (make-hash))
(define elements (make-hash)) (define elements (make-hash))
(define html-handle #f)
(define (event-handler type evt content) (define (event-handler evt content)
(ww-debug (format "win-id=~a '~a '~a ~a" win-id type evt content)) (ww-debug (format "win-id=~a '~a ~a" win-id evt content))
(cond (cond
([eq? evt 'page-loaded] (send this html-loaded)) ([eq? evt 'page-loaded] (let ((page-handle (hash-ref content 'page_handle 'none)))
([eq? evt 'click] (handle-click (car content) (cadr content))) (ww-debug (format "html-handle: ~a, page-handle: ~a, equal?: ~a"
([eq? evt 'input] (handle-input (car content) (cadr content))) html-handle
([eq? evt 'change] (handle-change (car content) (cadr content))) page-handle
([eq? evt 'resized] (let* ((m (regexp-match re-resize content)) (equal? html-handle page-handle)))
(width* (string->number (cadr m))) (when (and (number? html-handle) (number? page-handle) (= html-handle page-handle))
(height* (string->number (caddr m))) (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! width width*)
(set! height height*))) (set! height height*)))
([eq? evt 'moved] (let* ((m (regexp-match re-move content)) ([eq? evt 'moved] (let* ((x* (hash-ref content 'x))
(x* (string->number (cadr m))) (y* (hash-ref content 'y))
(y* (string->number (caddr m)))
) )
(set! x x*) (set! x x*)
(set! y y*) (set! y y*)
)) ))
([eq? evt 'request-close] (when (send this can-close?) ([eq? evt 'request-close] (when (send this can-close?)
(send this 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))) (cb (hash-ref menu-cbs menu-id #f)))
(unless (eq? cb #f) (unless (eq? cb #f)
(cb)))) (cb))))
([eq? evt 'navigate] (let* ((m (regexp-match re-navigate content)) ([eq? evt 'navigate] (let* ((url (hash-ref content 'url))
(url (ww-from-string (cadr m))) (kind (string->symbol (hash-ref content
(type (string->symbol (caddr m))) 'navigation-kind)))
(kind (string->symbol (cadddr m))) (type (string->symbol (hash-ref content
'navigation-type)))
) )
(send this handle-navigate url type kind))) (send this handle-navigate url type kind)))
) )
@@ -335,12 +349,13 @@
(define/public (handle-click element-id data) (define/public (handle-click element-id data)
(let ((el (hash-ref elements element-id #f))) (let ((el (hash-ref elements element-id #f)))
(unless (eq? el #f) (unless (eq? el #f)
(ww-debug (format "CALLING CALLBACK FOR ~a" element-id))
(send el callback 'click data)))) (send el callback 'click data))))
(define/public (handle-change element-id data) (define/public (handle-change element-id data)
(let ((el (hash-ref elements element-id #f))) (let ((el (hash-ref elements element-id #f)))
(unless (eq? el #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) (define/public (handle-input element-id data)
(let ((el (hash-ref elements element-id #f))) (let ((el (hash-ref elements element-id #f)))
@@ -350,7 +365,7 @@
(define/public (handle-navigate url type kind) (define/public (handle-navigate url type kind)
(let ((method (if (eq? kind 'set-html) 'set-html-file! 'set-url))) (let ((method (if (eq? kind 'set-html) 'set-html-file! 'set-url)))
(cond (cond
([eq? type 'link-clicked] ([eq? type 'standard]
(dynamic-send this method url)) (dynamic-send this method url))
(else (ww-error (format "Don't know what to do for ~a - ~a" type url))) (else (ww-error (format "Don't know what to do for ~a - ~a" type url)))
) )
@@ -435,12 +450,15 @@
(define/public (get-title) (define/public (get-title)
title) title)
(define/public (set-icon! icn)
(ww-set-icon win-id icn))
(define/public (set-html-file! file) (define/public (set-html-file! file)
(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) (define/public (set-url url)
(ww-set-url win-id url)) (send-url url))
(define/public (html-loaded) (define/public (html-loaded)
(send this bind-buttons) (send this bind-buttons)
@@ -468,23 +486,23 @@
(ww-set-show-state win-id 'fullscreen)) (ww-set-show-state win-id 'fullscreen))
(define/public (show-state) (define/public (show-state)
(ww-show-state win-id)) (ww-get-show-state win-id))
(define/public (can-close?) (define/public (can-close?)
#t) #t)
(define/public (close) (define/public (close)
(ww-close win-id) (ww-close win-id)
(hash-remove! windows win-id) (hash-remove! windows (ww-win-id win-id))
(hash-remove! windows-evt-handlers win-id) (hash-remove! windows-evt-handlers (ww-win-id win-id))
(when (= (hash-count windows) 0) (when (= (hash-count windows) 0)
(ww-stop)) (ww-stop))
) )
(define/public (set-menu menu-def) (define/public (set-menu! menu-def)
(ww-set-menu win-id 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)) (hash-set! menu-cbs id cb))
; files and directories ; files and directories
@@ -534,7 +552,10 @@
) )
) )
) )
; Supers first
(super-new)
; construct ; construct
(begin (begin
(when (= (hash-count windows) 0) (when (= (hash-count windows) 0)
@@ -550,29 +571,31 @@
(next-window-init-position) (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) (when (eq? win-id #f)
(error "Window could not be constructed")) (error "Window could not be constructed"))
(hash-set! windows-evt-handlers win-id event-handler) (hash-set! windows-evt-handlers (ww-win-id win-id) event-handler)
(hash-set! windows win-id this) (hash-set! windows (ww-win-id win-id) this)
(ww-move win-id x y) (ww-move win-id x y)
(ww-resize win-id width height) (ww-resize win-id width height)
(ww-set-title win-id title) (send this set-title! title)
(unless (eq? icon #f) (unless (eq? icon #f)
(ww-set-icon win-id icon)) (send this set-icon! icon))
(unless (eq? menu #f) (unless (eq? menu #f)
(ww-set-menu win-id menu)) (send this set-menu! menu))
(unless (eq? html-file #f) (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) (define (set-global-stylesheet st)
@@ -587,11 +610,18 @@
;; Testing stuff ;; Testing stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test-menu (define test-menu (menu (menu-item 'm-file "File"
'(("File" (("Open" open) ("Close" close) ("Quit" quit))) #:submenu
("Edit" (("Copy" copy) ("Advanced" (("Copy 1" copy1) ("Copy 2" copy2))) (menu (menu-item 'm-open "Open File")
("Cut" cut) ("Paste" paste))) (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% (define test-dialog%
(class ww-window% (class ww-window%
@@ -601,6 +631,7 @@
(define/override (html-loaded) (define/override (html-loaded)
(super html-loaded) (super html-loaded)
(ww-debug "html-loaded for test-dialog%")
(let* ((btn (send this element 'ok-btn))) (let* ((btn (send this element 'ok-btn)))
(send btn connect 'click (λ (data) (send btn connect 'click (λ (data)
(send this close))))) (send this close)))))
@@ -611,15 +642,17 @@
(super-new [html-file "../../web-wire/test/test1.html"]) (super-new [html-file "../../web-wire/test/test1.html"])
(define/override (html-loaded) (define/override (html-loaded)
(ww-debug "HTML LOADED")
(super html-loaded) (super html-loaded)
(let* ((btn (send this element 'app-button))) (let* ((btn (send this element 'app-button)))
(send btn connect 'click (λ (data) (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 (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 ffi/unsafe/atomic
setup/dirs setup/dirs
"../utils/utils.rkt" "../utils/utils.rkt"
(prefix-in g: racket/gui) (rename-in racket/gui
(-> %->))
data/queue
) )
(provide webwire-new (provide webwire-new
webwire-current webwire-current
webwire-id
webwire-destroy webwire-destroy
webwire-command webwire-command
webwire-items webwire-items
webwire-items-available
webwire-handlers!
webwire-get webwire-get
webwire-status webwire-status
webwire-status->string webwire-status->string
@@ -81,8 +86,8 @@
#:c-id webwire_destroy) #:c-id webwire_destroy)
(define-libwebui-wire webwire-command (define-libwebui-wire webwire-command
(_fun _webui-handle/null _string/utf-8 (_fun _webui-handle/null _string*/utf-8
-> [r : _string/utf-8] -> [r : _string*/utf-8]
-> r -> r
) )
#:c-id webwire_command) #:c-id webwire_command)
@@ -93,9 +98,9 @@
(define-libwebui-wire webwire-get (define-libwebui-wire webwire-get
(_fun _webui-handle/null (_fun _webui-handle/null
[evt : (_ptr o _string/utf-8)] [evt : (_ptr o _string*/utf-8)]
[kind : (_ptr o _string/utf-8)] [kind : (_ptr o _string*/utf-8)]
[msg : (_ptr o _string/utf-8)] [msg : (_ptr o _string*/utf-8)]
-> [ result : _webui-get-result ] -> [ result : _webui-get-result ]
-> (list result -> (list result
evt evt
@@ -104,19 +109,28 @@
) )
#:c-id webwire_get) #:c-id webwire_get)
#| (define-libwebui-wire webwire-id
(if (eq? evt #f) (_fun _webui-handle/null
#f -> _int)
(cast evt _pointer _string/utf-8)) #:c-id webwire_handle_id)
(if (eq? kind #f)
#f (define my-count 0)
(string->symbol (define last-queue-count -1)
(cast kind _pointer _string/utf-8))) (define (f c) (set! my-count (+ my-count 1)) (set! last-queue-count c))
(if (eq? msg #f)
#f (define (appl thunk)
(cast msg _pointer _string/utf-8)) (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 (define-libwebui-wire webwire-status
(_fun _webui-handle/null -> _webui-handle-status) (_fun _webui-handle/null -> _webui-handle-status)
@@ -125,7 +139,7 @@
(define-libwebui-wire webwire-status->string (define-libwebui-wire webwire-status->string
(_fun _webui-handle-status (_fun _webui-handle-status
-> (r : _string/utf-8) -> (r : _string*/utf-8)
-> r) -> r)
#:c-id webwire_status_string) #:c-id webwire_status_string)
@@ -181,3 +195,65 @@
(f)))))) (f))))))
(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))))))