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

ok

Browse Source
This commit is contained in:
Hans Dijkema
2025-08-25 01:29:58 +02:00
parent 1527026ad9
commit 5f8bf415ff
2 changed files with 140 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

96
private/web-racket.rkt
View File

@@ -27,7 +27,7 @@
(define re-move re-resize)
(define re-file-open #px"([0-9]+)[:]([^:]+)[:](.*)")
(define re-choose-dir re-file-open)
(define re-navigate #px"(.*)[:]([^:]+)$")
(define re-navigate #px"(.*)[:]([^:]+)[:]([^:]+)$")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GUI classes
@@ -89,6 +89,18 @@
(define/public (style)
(ww-get-style win-id id))
(define/public (get-attr a)
(ww-get-attr win-id id a))
(define/public (set-attr! a val)
(ww-set-attr win-id id a val))
(define/public (del-attr a)
(ww-del-attr win-id id a))
(define/public (get-attrs)
(ww-get-attrs win-id id))
(define/public (add-class! cl)
(ww-add-class win-id id cl))
@@ -166,6 +178,7 @@
(init-field [profile 'default-profile]
[parent-id #f]
[parent #f]
[title "Racket HTML Window"]
[x _std_x]
[y _std_y]
@@ -182,11 +195,9 @@
(define elements (make-hash))
(define (event-handler type evt content)
(displayln (format "win-id=~a '~a '~a ~a" win-id type evt content))
(ww-debug (format "win-id=~a '~a '~a ~a" win-id type evt content))
(cond
([eq? evt 'page-loaded] (begin
(send this bind-buttons)
(send this bind-inputs)))
([eq? evt 'page-loaded] (send this html-loaded))
([eq? evt 'click] (handle-click (car content) (cadr content)))
([eq? evt 'change] (handle-change (car content) (cadr content)))
([eq? evt 'resized] (let* ((m (regexp-match re-resize content))
@@ -209,9 +220,11 @@
(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))))
(send this handle-navigate url type)))
(url (ww-from-string (cadr m)))
(type (string->symbol (caddr m)))
(kind (string->symbol (cadddr m)))
)
(send this handle-navigate url type kind)))
)
)
@@ -225,12 +238,15 @@
(unless (eq? el #f)
(send el callback 'change (hash-ref data 'value)))))
(define/public (handle-navigate url type)
(cond
([eq? type 'link-clicked]
(send this set-url url))
(else (ww-error (format "Don't know what to do for ~a - ~a" type url)))
))
(define/public (handle-navigate url type kind)
(let ((method (if (eq? kind 'set-html) 'set-html-file! 'set-url)))
(cond
([eq? type 'link-clicked]
(dynamic-send this method url))
(else (ww-error (format "Don't know what to do for ~a - ~a" type url)))
)
)
)
(define/public (get-win-id) win-id)
@@ -249,7 +265,7 @@
(let* ((id (car info))
(tag (cadr info))
(type (caddr info)))
(displayln (format "bind: ~a ~a ~a" id tag type))
(ww-debug (format "bind: ~a ~a ~a" id tag type))
(let ((cl (if (null? forced-cl)
(cl-selector tag type)
(car forced-cl))))
@@ -267,10 +283,10 @@
)
(define/public (element id)
(let ((el (hash-ref elements id #f)))
(if (eq? el #f)
(let ((el (hash-ref elements id 'no-element-with-id-in-hash)))
(if (eq? el 'no-element-with-id-in-hash)
(let ((info (ww-element-info win-id id)))
(let* ((id (car info))
(let* ((el-id (car info))
(tag (cadr info))
(type (caddr info))
(exist (cadddr info))
@@ -279,10 +295,14 @@
(ww-debug (format "Element ~a does not exist!" id)))
(let* ((cl (cl-selector tag type))
(obj (new cl [win-id win-id] [id id])))
(hash-set! elements id obj)))
(hash-set! elements el-id obj)
))
(element id))
el)))
(define/public (get-elements selector)
(ww-get-elements win-id selector))
(define/public (move x y)
(ww-move win-id x y))
@@ -294,7 +314,6 @@
(define/public (get-width) width)
(define/public (get-height) height)
(define/public (geom) (list x y width height))
(define/public (set-title! t)
(set! title t)
@@ -310,6 +329,10 @@
(define/public (set-url url)
(ww-set-url win-id url))
(define/public (html-loaded)
(send this bind-buttons)
(send this bind-inputs))
(define/public (get-html-file)
html-file)
@@ -403,6 +426,14 @@
(begin
(when (= (hash-count windows) 0)
(ww-start))
(when (eq? parent-id #f)
(unless (eq? parent #f)
(set! parent-id (send parent get-win-id))))
(when (eq? parent #f)
(unless (eq? parent-id #f)
(set! parent (ww-get-window-for-id parent-id))))
(next-window-init-position)
@@ -449,14 +480,35 @@
("Cut" cut) ("Paste" paste)))
))
(define test-dialog%
(class ww-window%
(super-new [html-file "../../web-wire/test/dialog.html"]
[width 400]
[height 300])
(define/override (html-loaded)
(super html-loaded)
(let* ((btn (send this element 'ok-btn)))
(send btn connect 'click (λ (data)
(send this close)))))
))
(define test-window%
(class ww-window%
(super-new [html-file "../../web-wire/test/test1.html"])
(define/override (html-loaded)
(super html-loaded)
(let* ((btn (send this element 'app-button)))
(send btn connect 'click (λ (data)
(new test-dialog% [parent this]))))
)
(begin
(send this set-menu test-menu)
(send this connect-menu 'quit (λ () (send this close)))
)
))
)
)
); end of module

77
private/web-wire.rkt
View File

@@ -45,6 +45,7 @@
ww-set-attr
ww-get-attr
ww-get-attrs
ww-del-attr
ww-set-style
@@ -58,6 +59,8 @@
ww-set-value
ww-get-value
ww-get-elements
ww-set-show-state
ww-show-state
@@ -71,6 +74,7 @@
windows
windows-evt-handlers
ww-get-window-for-id
ww-from-string
)
@@ -230,6 +234,9 @@
(define windows-evt-handlers (make-hash))
(define windows (make-hash))
(define (ww-get-window-for-id win-id)
(hash-ref windows win-id #f))
(define handle-results (make-hash))
(define handle-semaphores (make-hash))
@@ -326,7 +333,10 @@
(more-lines (- lines 1))
)
(while (> more-lines 0)
(let ((line (string-trim (read-line err-ww))))
(let* ((line* (read-line err-ww))
(line (if (eof-object? line*)
""
(string-trim line*))))
(set! rest (string-append rest "\n" line))
(set! more-lines (- more-lines 1))
))
@@ -425,13 +435,18 @@
(ww-error
(format "Unexpected: (eq? ww-from-ww #f), for command '~a" cmd))
(cons #f 'nil))
(let ((line-in (string-trim (read-line ww-from-ww))))
(let* ((line-in* (read-line ww-from-ww))
(line-in (if (eof-object? line-in*)
"NOK(1):eof:0"
(string-trim line-in*)))
)
(let ((ok (string-prefix? line-in "OK("))
(nok (string-prefix? line-in "NOK("))
(nok (or (string=? line-in "")
(string-prefix? line-in "NOK(")))
)
(let ((m (regexp-match re-kind line-in)))
(unless m
(error (format "Input not expected: ~a" line-in)))
(ww-debug (format "Input not expected: \"~a\", maybe ww-quit issued" line-in)))
(let* ((kind (cadr m))
(lines (string->number (caddr m)))
(result-str (substring line-in (string-length (car m))))
@@ -439,11 +454,17 @@
)
;(displayln result-str)
;(displayln (format "~a ~a ~a" kind lines more-lines))
(while (> more-lines 0)
(set! result-str (string-append
result-str "\n"
(string-trim (read-line ww-from-ww))))
(set! more-lines (- more-lines 1)))
(let ((rdln (λ ()
(let ((l (read-line ww-from-ww)))
(if (eof-object? l)
""
(string-trim l))))))
(while (> more-lines 0)
(set! result-str (string-append
result-str "\n"
(rdln)))
(set! more-lines (- more-lines 1)))
)
(cons ok result-str)
))))
)
@@ -743,6 +764,35 @@
(as-string element-id) (as-string attr))))
(ww-await js-handle cmd)))
;; Get all attributes of an element with given id
(define (mk-attrs _attrs)
(let* ((attrs (make-hash)))
(for-each (λ (attr-val)
(hash-set! attrs
(string->symbol (car attr-val))
(cadr attr-val)))
_attrs)
attrs)
)
(define (ww-get-attrs win-id element-id)
(let* ((js-handle (new-handle))
(cmd (format "get-attrs ~a ~a ~a" win-id js-handle
(as-string element-id))))
(mk-attrs (ww-await js-handle cmd))))
;; Get info of all elements for a selector
(define (ww-get-elements win-id selector)
(let* ((js-handle (new-handle))
(cmd (format "get-elements ~a ~a ~a" win-id js-handle
(as-string selector))))
(map (λ (item)
(cons (string->symbol (car item))
(mk-attrs (cadr item)))
)
(ww-await js-handle cmd))))
;; Delete attribute of element
(define (ww-del-attr win-id element-id attr)
(let* ((js-handle (new-handle))
@@ -791,8 +841,13 @@
(let* ((js-handle (new-handle))
(cmd (format "element-info ~a ~a ~a" win-id js-handle
(as-string id))))
(ww-await js-handle cmd)))
(let ((result (ww-await js-handle cmd)))
(list (if (symbol? id)
(string->symbol (car result))
(car result))
(string->symbol (cadr result))
(string->symbol (caddr result))
(cadddr result)))))
;; Add a class to an element
(define (ww-add-class win-id element-id class)