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

Asynchronous messages, file dialogs and call/cc stuff

Browse Source
This commit is contained in:
Hans Dijkema
2026-03-12 17:08:20 +01:00
parent d99c5a1725
commit 2cbf6fb98b
11 changed files with 363 additions and 199 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
private/lib/linux/x86_64/librktwebview_qt.so
View File

Binary file not shown.

91
private/racket-webview-qt.rkt
View File

@@ -40,6 +40,7 @@
rkt-webview-choose-dir
rkt-webview-file-open
rkt-webview-file-save
rkt-webview-messagebox
rkt-webview-version
)
@@ -226,6 +227,16 @@
)
)
(define _rkt_messagetype_t
(_enum '(info = 1
error = 2
warning = 3
yes-no = 4
oke-cancel = 5
)
)
)
(define-cstruct _rkt_version_t
([qt-major _int]
[qt-minor _int]
@@ -357,15 +368,24 @@
;RKTWEBVIEW_QT_EXPORT rkt_js_result_t *rkt_webview_choose_dir(rktwebview_t w, const char *title, const char *base_dir);
(define-rktwebview rkt_webview_choose_dir
(_fun _int _string/utf-8 _string/utf-8 -> _rkt_data_t-pointer))
(_fun _int _string/utf-8 _string/utf-8 -> _rkt_result_t))
;RKTWEBVIEW_QT_EXPORT rkt_js_result_t *rkt_webview_file_open(rktwebview_t w, const char *title, const char *base_dir, const char *permitted_exts);
(define-rktwebview rkt_webview_file_open
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 -> _rkt_data_t-pointer))
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 -> _rkt_result_t))
;RKTWEBVIEW_QT_EXPORT rkt_js_result_t *rkt_webview_file_save(rktwebview_t w, const char *title, const char *base_dir, const char *permitted_exts);
(define-rktwebview rkt_webview_file_save
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 -> _rkt_data_t-pointer))
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 -> _rkt_result_t))
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_message_box(
; rktwebview_t w,
; const char *title,
; const char *message,
; const char *submessage,
; rkt_messagetype_t type);
(define-rktwebview rkt_webview_message_box
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 _rkt_messagetype_t -> _rkt_result_t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -405,20 +425,21 @@
(define (rkt-process-events handle)
(if (> (queue-length (rkt-wv-evt-queue handle)) 0)
(let ((data (dequeue! (rkt-wv-evt-queue handle))))
(if (symbol? data)
(if (eq? data 'quit)
(let ((evt (dequeue! (rkt-wv-evt-queue handle))))
(if (symbol? evt)
(if (eq? evt 'quit)
(begin
(hash-remove! rkt-wv-store (rkt-wv-win handle))
'quit)
(rkt-process-events handle))
(let* ((e (union-ref (rkt_data_t-data data) 1))
(evt (cast (rkt_evt_t-evt e) _pointer _string*/utf-8)))
(begin
(displayln (format "Unexpected data in event queue: ~a" evt))
(rkt-process-events handle)))
(begin
((rkt-wv-callback handle) handle evt)
(rkt_webview_free_data data)
(rkt-process-events handle)))
)
'done))
'done)
)
(define (rkt-webview-new-context boilerplate-js server-cert)
@@ -431,7 +452,11 @@
)
(let ((wv (rkt_webview_create context parent-win
(λ (rkt-evt)
(enqueue! evt-queue rkt-evt)))))
(let* ((e (union-ref (rkt_data_t-data rkt-evt) 1))
(evt (cast (rkt_evt_t-evt e) _pointer _string*/utf-8)))
(rkt_webview_free_data rkt-evt) ; Free event data ASAP
(enqueue! evt-queue evt)
)))))
(let ((handle (make-rkt-wv wv evt-queue evt-callback #t close-callback)))
(thread (λ ()
(sleep 1)
@@ -504,28 +529,34 @@
(rkt_webview_open_devtools (rkt-wv-win wv)))
(define (rkt-webview-choose-dir wv title base-dir)
(let* ((d (rkt_webview_choose_dir (rkt-wv-win wv) title base-dir))
(r (union-ref (rkt_data_t-data d) 2))
(value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
(result (rkt_js_result_t-result r)))
(rkt_webview_free_data d)
(list result value)))
(rkt_webview_choose_dir (rkt-wv-win wv) title base-dir))
; (let* ((d (rkt_webview_choose_dir (rkt-wv-win wv) title base-dir))
; (r (union-ref (rkt_data_t-data d) 2))
; (value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
; (result (rkt_js_result_t-result r)))
; (rkt_webview_free_data d)
; (list result value)))
(define (rkt-webview-file-open wv title base-dir permitted-exts)
(let* ((d (rkt_webview_file_open (rkt-wv-win wv) title base-dir permitted-exts))
(r (union-ref (rkt_data_t-data d) 2))
(value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
(result (rkt_js_result_t-result r)))
(rkt_webview_free_data d)
(list result value)))
(rkt_webview_file_open (rkt-wv-win wv) title base-dir permitted-exts))
; (let* ((d (rkt_webview_file_open (rkt-wv-win wv) title base-dir permitted-exts))
; (r (union-ref (rkt_data_t-data d) 2))
; (value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
; (result (rkt_js_result_t-result r)))
; (rkt_webview_free_data d)
; (list result value)))
(define (rkt-webview-file-save wv title base-dir permitted-exts)
(let* ((d (rkt_webview_file_save (rkt-wv-win wv) title base-dir permitted-exts))
(r (union-ref (rkt_data_t-data d) 2))
(value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
(result (rkt_js_result_t-result r)))
(rkt_webview_free_data d)
(list result value)))
(rkt_webview_file_save (rkt-wv-win wv) title base-dir permitted-exts))
; (let* ((d (rkt_webview_file_save (rkt-wv-win wv) title base-dir permitted-exts))
; (r (union-ref (rkt_data_t-data d) 2))
; (value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
; (result (rkt_js_result_t-result r)))
; (rkt_webview_free_data d)
; (list result value)))
(define (rkt-webview-messagebox wv title message submessage type)
(rkt_webview_message_box (rkt-wv-win wv) title message submessage type))
(define (rkt-webview-version)
(let ((d (rkt_webview_version)))

82
private/racket-webview.rkt
View File

@@ -48,6 +48,8 @@
webview-window-state
webview-set-title!
webview-messagebox
webview-choose-dir
webview-file-open
webview-file-save
@@ -61,6 +63,7 @@
wv-permitted-exts?
wv-permitted-exts-exts?
wv-list-of-permitted-exts?
webview-filter->exts
webview-bind!
webview-unbind!
@@ -101,6 +104,7 @@
;webview-del-attr!
webview-standard-file-getter
webview-default-boilerplate-js
webview-version
@@ -116,9 +120,14 @@
(define-runtime-path js-path "../js")
(define (default-boilerplate-js)
(define (webview-default-boilerplate-js . custom-js)
(let ((file (build-path js-path "boilerplate.js")))
(file->string file)))
(let ((bjs (file->string file)))
(let ((js (string-append bjs
(if (null? custom-js)
""
((car custom-js))))))
js))))
(define-struct wv-context
([context #:mutable]
@@ -346,7 +355,7 @@
(map (λ (e) (format "*.~a" e)) (wv-permitted-exts-exts pe))))
(string-join (map mef (if (list? list-of-pe) list-of-pe (list list-of-pe))) ";;"))
(define (filter->exts str)
(define (webview-filter->exts str)
(let ((re #px"^([^ ]+)\\s+[(]([^)]+)[)]"))
(let ((m (regexp-match re str)))
(cond ((eq? m #f)
@@ -401,7 +410,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (webview-new-context file-getter
#:boilerplate-js [bj (default-boilerplate-js)])
#:boilerplate-js [bj (webview-default-boilerplate-js)])
(->* (procedure?) (#:boilerplate-js string?) wv-context?)
(let* ((h (make-wv-context 0 0 file-getter #f #f 0
(make-lru 250 #:cmp eq?)
@@ -527,48 +536,58 @@
(def-win-func webview-present rkt-webview-present)
(def-win-func webview-window-state rkt-webview-window-state)
(define/contract (webview-messagebox wv type title message #:sub [submessage ""])
(->* (wv-win? symbol? string? string?) (#:sub string?) symbol?)
(rkt-webview-messagebox (wv-win-handle wv) title message submessage type))
(define/contract (webview-choose-dir wv title base-dir)
(-> wv-win? string? (or/c path? string?) (or/c hash? boolean?))
(-> wv-win? string? (or/c path? string?) symbol?)
(let ((bd (if (path? base-dir) (path->string base-dir) base-dir)))
(let ((res (rkt-webview-choose-dir (wv-win-handle wv) title bd)))
(if (eq? res #f)
#f
(cond ((eq? (car res) 'oke)
(let ((r (make-hash (hash->list (fromJson (cadr res))))))
(hash-set! r 'state (string->symbol (hash-ref r 'state)))
r))
(else #f))
)
)
res)
)
)
;(if (eq? res #f)
; #f
; (cond ((eq? (car res) 'oke)
; (let ((r (make-hash (hash->list (fromJson (cadr res))))))
; (hash-set! r 'state (string->symbol (hash-ref r 'state)))
; r))
; (else #f))
; )
; )
; )
; )
(define (file-open-save wv title base-dir permitted-exts open-save-f)
(let* ((bd (if (path? base-dir) (path->string base-dir) base-dir))
(ext-filter (make-exts-filter permitted-exts)))
(displayln ext-filter);
(let ((res (open-save-f (wv-win-handle wv) title bd ext-filter)))
(if (eq? res #f)
#f
(cond ((eq? (car res) 'oke)
(let* ((h (make-hash (hash->list (fromJson (cadr res))))))
(hash-set! h 'state (string->symbol (hash-ref h 'state)))
(hash-set! h 'used-filter (filter->exts (hash-ref h 'used-filter)))
h))
(else #f))
)
)
)
)
res)))
; (if (eq? res #f)
; #f
; (cond ((eq? (car res) 'oke)
; (let* ((h (make-hash (hash->list (fromJson (cadr res))))))
; (hash-set! h 'state (string->symbol (hash-ref h 'state)))
; (hash-set! h 'used-filter (filter->exts (hash-ref h 'used-filter)))
; h))
; (else #f))
; )
; )
; )
; )
(define/contract (webview-file-open wv title base-dir permitted-exts)
(-> wv-win? string? (or/c path? string?) (or/c wv-permitted-exts? wv-list-of-permitted-exts?)
(or/c hash? boolean?))
symbol?)
(file-open-save wv title base-dir permitted-exts rkt-webview-file-open))
(define/contract (webview-file-save wv title base-dir permitted-exts)
(-> wv-win? string? (or/c path? string?) (or/c wv-permitted-exts? wv-list-of-permitted-exts?)
(or/c hash? boolean?))
symbol?)
(file-open-save wv title base-dir permitted-exts rkt-webview-file-save))
@@ -655,9 +674,10 @@
(define/contract (webview-set-innerHTML! wv id html)
(-> wv-win? symbol? (or/c string? xexpr?) symbol?)
(if (string? html)
(webview-run-js wv
(with-id id el
("el.innerHTML = '~a';" (esc-quote html))))
(let ((r (webview-call-js wv
(with-id id el
("el.innerHTML = '~a'; return true;" (esc-quote html))))))
(if r 'oke 'failed))
(webview-set-innerHTML! wv id (xexpr->string html))
)
)