This commit is contained in:
2025-08-23 02:53:54 +02:00
parent 02890d0a26
commit 38fcf0265f
2 changed files with 488 additions and 126 deletions

207
private/css.rkt Normal file
View File

@@ -0,0 +1,207 @@
(module css racket/base
(require racket/string)
(provide css-style
css-style->list
set-css!
get-css
clear-css!
css-keys
css-style?
string->css-style
css-style->string
stylesheet
stylesheet?
stylesheet-set!
stylesheet-get
stylesheet-clear!
stylesheet-keys
stylesheet->string
string->stylesheet
)
(define-struct style
(
[style #:auto #:mutable]
)
#:auto-value (make-hash))
(define-struct css-stylesheet
(
[sheet #:auto #:mutable]
)
#:auto-value (make-hashalw))
(define st-style style-style)
(define make-st make-style)
(define st? style?)
(define stylesheet? css-stylesheet?)
(define make-stylesheet make-css-stylesheet)
(define stylesheet-sheet css-stylesheet-sheet)
(define (css-style style_or_styles . args)
(if (symbol? style_or_styles)
(let ((css (if (null? args) "" (car args)))
(st (make-st)))
(hash-set! (st-style st) style_or_styles css)
st)
(let* ((st (make-st))
(h (st-style st)))
(for-each (lambda (st)
(let ((entry (car st))
(css (cadr st)))
(hash-set! h entry css)))
style_or_styles)
st)))
(define (set-css! st entry css)
(hash-set! (st-style st) entry css)
st)
(define (get-css st entry)
(hash-ref (st-style st) entry ""))
(define (clear-css! st entry)
(hash-remove! (st-style st) entry))
(define (css-style? st)
(st? st))
(define (css-keys st)
(hash-keys (st-style st)))
(define (css-style->list st)
(let* ((h (st-style st))
(keys (hash-keys h)))
(map (lambda (k)
(list k (hash-ref h k)))
keys)))
(define (css-style->string st . custom-sep)
(let* ((sep (if (null? custom-sep) " " (car custom-sep)))
(h (st-style st))
(keys (hash-keys h)))
(letrec ((f (lambda (keys)
(if (null? keys)
""
(let ((key (car keys)))
(string-append (symbol->string key)
": "
(hash-ref h key)
";"
sep
(f (cdr keys))))
))
))
(string-trim (f keys)))))
(define re-style-split #px"\\s*[;]\\s*")
(define re-style-kv-split #px"\\s*[:]\\s*")
(define (split-style-string style)
(let ((sp-style (regexp-split re-style-split style)))
(letrec ((f (lambda (entries)
(if (null? entries)
'()
(let* ((entry (string-trim (car entries)))
(kv (regexp-split re-style-kv-split entry))
(key (car kv))
(skey (if (string? key)
(string->symbol key)
key))
(val (if (= (length kv) 2) (cadr kv) ""))
(keyval (list skey val))
)
(if (string=? entry "")
(f (cdr entries))
(cons keyval (f (cdr entries)))))
))
))
(f sp-style))))
(define (string->css-style style-str)
(css-style (split-style-string style-str)))
(define (stylesheet entry_or_entries . style)
(if (symbol? entry_or_entries)
(let* ((st (car style))
(ss (make-stylesheet))
(h (stylesheet-sheet ss)))
(if (css-style? st)
(begin
(hash-set! h entry_or_entries st)
ss)
(error "A css-style is expected")))
(let* ((ss (make-stylesheet))
(h (stylesheet-sheet ss)))
(for-each (lambda (entry)
(let* ((key (car entry))
(s (cadr entry)))
(if (css-style? s)
(hash-set! h key s)
(error (format "A css-style is expected for ~a"
key)))
))
entry_or_entries)
ss)))
(define (string->stylesheet str)
(error "Not implemented yet")
#t)
(define (stylesheet-entry->string e)
(if (list? e)
(if (null? e)
""
(string-append (stylesheet-entry->string (car e))
" "
(stylesheet-entry->string (cdr e))))
(format "~a" e)))
(define (stylesheet->string ss)
(let* ((h (stylesheet-sheet ss))
(keys (hash-keys h))
(sep "\n"))
(letrec ((f (lambda (keys)
(if (null? keys)
""
(let* ((key (car keys))
(st (hash-ref h key)))
(string-append (stylesheet-entry->string key) " {\n "
(css-style->string st "\n ")
"\n}\n"
(f (cdr keys))))))
))
(f keys))))
(define (stylesheet-set! ss key style)
(let ((h (stylesheet-sheet ss)))
(hash-set! h key style)
ss))
(define (stylesheet-get ss key)
(let ((h (stylesheet-sheet ss)))
(hash-ref h key (make-st))))
(define (stylesheet-clear! ss key)
(let ((h (stylesheet-sheet ss)))
(hash-remove! h key)))
(define (stylesheet-keys ss)
(let ((h (stylesheet-sheet ss)))
(hash-keys h)))
); end of module

View File

@@ -7,10 +7,11 @@
file/unzip
net/url
racket/port
roos
data/queue
json
"../utils/utils.rkt"
"css.rkt"
html-printer
)
(provide ww-start
@@ -22,8 +23,6 @@
ww-resize
ww-set-title
ww-set-icon
)
(define current-win-release "https://github.com/hdijkema/web-wire/releases/download/0.1/web-wire-0.1-win64.zip")
@@ -127,21 +126,34 @@
(define ww-quit #f)
(define ww-debug #f)
(define (ww-set-debug yn)
(set! ww-debug yn))
(define (debug str)
(define (ww-set-debug yn) (set! ww-debug yn))
(define (do-debug str . var)
(when ww-debug
(displayln str)))
(if (null? var)
(displayln (format "Debug: ~a" str))
(displayln (format "Debug: ~a: ~a" var str))
)))
(define (err str)
(displayln (format "Error: ~a" str)))
(define-syntax debug
(syntax-rules ()
((_ str)
(do-debug str))
((_ var str)
(do-debug str 'var))
))
(define re-kind #px"([A-Z]+)[(]([0-9]+)[)][:]")
(define re-event #px"([^:]+)[:]([0-9]+)([:](.*))?")
(define re-js-event #px"^([^:]+)([:](.*))?")
(define re-js-result #px"([0-9]+)[:]([^:]+)[:](.*)")
(define re-js-handle #px"([^:]+)[:]([0-9]+)[:]([0-9]+)([:](.*))?")
(define windows-evt-handlers (make-hash))
(define windows (make-hash))
(define handle-results (make-hash))
@@ -164,14 +176,18 @@
(define protocol-version 0)
(define (handle-event line)
(debug (format "Handling ~a" line))
(let ((m (regexp-match re-event line)))
(if (eq? m #f)
(err (format "Cannot interpret input: ~a" line))
(let* ((evt (string->symbol (cadr m)))
(let* ((str-evt (cadr m))
(evt (string->symbol str-evt))
(win-id (string->number (caddr m)))
(content (car (cddddr m)))
(win (hash-ref windows win-id #f))
(win* (hash-ref windows-evt-handlers win-id #f))
(win (if (eq? win* #f) #f (weak-box-value win*)))
)
;(debug content content)
(unless (or (eq? evt 'closed) (eq? evt 'js-result))
(if (eq? win #f)
(begin
@@ -179,8 +195,19 @@
(err (format "Cannot handle event '~a " evt))
(err (format "input: ~a" line))
)
(if (string-prefix? str-evt "js-")
(let* ((evt (string->symbol (substring str-evt 3)))
(m (regexp-match re-js-event content))
(element-id (string->symbol (cadr m)))
(content (string-trim (cadddr m)))
(h (with-input-from-string content read-json))
(data (if (string=? content "")
""
(hash-ref h 'data #f)))
)
(queue-callback (lambda ()
(win evt content)))
(win 'js evt (list element-id data)))))
(queue-callback (lambda () (win 'other evt content))))
))
(when (eq? evt 'js-result)
(let ((m (regexp-match re-js-result content)))
@@ -189,19 +216,13 @@
(let* ((handle (string->number (cadr m)))
(func (caddr m))
(content (cadddr m))
(data (with-input-from-string
(with-input-from-string
content read-json)
read-json))
(data (with-input-from-string content read-json))
(result (hash-ref data 'result))
)
;(displayln handle)
;(displayln func)
;(displayln content)
;(displayln data)
(if (hash-has-key? handle-results handle)
(begin
; a result is expected
(hash-set! handle-results handle data)
(hash-set! handle-results handle result)
(semaphore-post (hash-ref handle-semaphores handle)))
(debug (format "not awaiting ~a: ~a" handle content)))
)
@@ -209,7 +230,7 @@
(when (eq? evt 'closed)
(if (eq? win #f)
(err (format "No such window ~a, cannot close" win-id))
(hash-remove! windows win-id)))
(hash-remove! windows-evt-handlers win-id)))
))
))
@@ -233,7 +254,11 @@
(set! more-lines (- more-lines 1))
))
(cond
([eq? kind 'EVENT] (handle-event rest))
([eq? kind 'EVENT]
(with-handlers ([exn:fail?
(lambda (e) (err (format "~a" e)))])
(handle-event rest))
)
(else (debug (format "~a(~a):~a" kind lines rest)))
))
))
@@ -333,7 +358,6 @@
)
(define (ww-await handle cmd)
(call/cc (lambda (continuation)
(hash-set! handle-semaphores handle (make-semaphore 0))
(hash-set! handle-results handle #f)
(let* ((r (ww-cmd cmd))
@@ -346,13 +370,11 @@
(hash-remove! handle-semaphores handle)
(let ((r (hash-ref handle-results handle)))
(hash-remove! handle-results handle)
(continuation r)))
r))
(begin
(hash-remove! handle-semaphores handle)
(hash-remove! handle-results handle)
(continuation #f))
)
)
#f)
)
)
)
@@ -363,6 +385,10 @@
;; Stop the QtWebEngine
(define (ww-stop)
(let ((win-ids (hash-keys windows-evt-handlers)))
(for-each (λ (win-id)
(ww-close win-id))
win-ids))
(let ((r (ww-cmd 'quit)))
(car r)))
@@ -594,8 +620,30 @@
;; Get attribute value of element in html
(define (ww-get-attr win-id element-id attr)
(let* ((js-handle (new-handle))
(cmd (format "get-attr ~a ~a ~a" win-id js-handle
(cmd (format "get-attr ~a ~a ~a ~a" win-id js-handle
(as-string element-id) (as-string attr))))
(ww-await js-handle cmd)))
;; Delete attribute of element
(define (ww-del-attr win-id element-id attr)
(let* ((js-handle (new-handle))
(cmd (format "del-attr ~a ~a ~a" win-id js-handle
(as-string element-id))))
(ww-cmd cmd)))
;; get value of an element
(define (ww-get-value win-id element-id)
(let* ((js-handle (new-handle))
(cmd (format "value ~a ~a ~a" win-id js-handle
(as-string element-id))))
(ww-await js-handle cmd)))
;; set value of an element
(define (ww-set-value win-id element-id val)
(let* ((js-handle (new-handle))
(cmd (format "value ~a ~a ~a ~a" win-id js-handle
(as-string element-id)
(as-string val))))
(ww-await js-handle cmd)))
@@ -627,8 +675,9 @@
;; Has a class
(define re-class-split #px"\\s+")
(define (ww-has-class? win-id element-id class)
(let ((cl (ww-get-attr win-id element-id "class")))
(define (ww-has-class? win-id element-id class*)
(let* ((cl (string-trim (ww-get-attr win-id element-id "class")))
(class (format "~a" class*)))
(if (eq? cl #f)
#f
(let* ((cls (regexp-split re-class-split cl)))
@@ -646,46 +695,9 @@
)
)
;; Style related stuff
(define (mk-style-string css-style)
(if (null? css-style)
""
(let* ((kv (car css-style))
(key (car kv))
(val* (cdr kv))
(val (if (list? val*) (car val*) val*))
)
(string-append (format "~a" key) ": " (format "~a" val) "; "
(mk-style-string (cdr css-style))))
))
(define re-style-split #px"\\s*[;]\\s*")
(define re-style-kv-split #px"\\s*[:]\\s*")
(define (split-style-string style)
(let ((sp-style (regexp-split re-style-split style)))
(letrec ((f (lambda (entries)
(if (null? entries)
'()
(let* ((entry (string-trim (car entries)))
(kv (regexp-split re-style-kv-split entry))
(key (car kv))
(skey (if (string? key)
(string->symbol key)
key))
(val (if (= (length kv) 2) (cadr kv) ""))
(keyval (cons skey val))
)
(if (string=? entry "")
(f (cdr entries))
(cons keyval (f (cdr entries)))))
))
))
(f sp-style))))
;; Add a style to an element
(define (ww-add-style win-id element-id css-style)
(let* ((st (mk-style-string css-style))
(let* ((st (css-style->string css-style))
(js-handle (new-handle))
(cmd (format "add-style ~a ~a ~a ~a" win-id js-handle
(as-string element-id) (as-string st)))
@@ -694,7 +706,7 @@
;; Set a style of an element
(define (ww-set-style win-id element-id css-style)
(let* ((st (mk-style-string css-style))
(let* ((st (css-style->string css-style))
(js-handle (new-handle))
(cmd (format "set-style ~a ~a ~a ~a" win-id js-handle
(as-string element-id) (as-string st)))
@@ -707,9 +719,25 @@
(cmd (format "get-style ~a ~a ~a" win-id js-handle
(as-string element-id)))
)
(split-style-string (ww-await js-handle cmd))))
(string->css-style (ww-await js-handle cmd))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Finalizing stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define will (make-will-executor))
(define (register-finalizer obj proc)
(will-register will obj proc))
(void (thread (λ () (let loop () (will-execute will) (loop)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define re-resize #px"([0-9]+)\\s+([0-9]+)")
(define re-move re-resize)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GUI classes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -731,25 +759,69 @@
(set! _std_x 50))
)))
(define ww-base%
(define ww-element%
(class object%
(init-field [win-id #f] [id #f])
(define/public (enable)
(ww-remove-class win-id id 'disabled))
(define/public (get-win-id)
win-id)
(define/public (enabled)
(not (ww-has-class? win-id id 'disabled)))
(define/public (get-id)
id)
(define/public (win)
(let ((w (hash-ref windows win-id #f)))
w))
(define connected-callbacks (make-hash))
(define/public (callback evt . args)
(let ((cb (hash-ref connected-callbacks evt #f)))
(unless (eq? cb #f)
(with-handlers ([exn:fail?
(λ (e)
(err (format "callback for ~a: ~a" evt e)))])
(apply cb args)))))
(define/public (connect evt func)
(hash-set! connected-callbacks evt func))
(define/public (disconnect evt)
(hash-remove! connected-callbacks evt))
(define/public (add-style! st)
(ww-add-style win-id id st))
(define/public (set-style! st)
(ww-set-style win-id id st))
(define/public (style)
(ww-get-style win-id id))
(define/public (add-class! cl)
(ww-add-class win-id id cl))
(define/public (remove-class! cl)
(ww-remove-class win-id id cl))
(define/public (has-class? cl)
(ww-has-class? win-id id cl))
(define/public (enable)
(send this remove-class! 'disabled))
(define/public (enabled?)
(not (send this disabled?)))
(define/public (disable)
(ww-add-class win-id id 'disabled))
(send this add-class! 'disabled))
(define/public (disabled)
(ww-has-class? win-id id 'disabled))
(define/public (disabled?)
(send this has-class? 'disabled))
(define/public (display . args)
(let ((d (if (null? args) "block" (car args))))
(ww-add-style win-id id (list (cons 'display d)))))
(send this add-style! (css-style 'display d))))
(define/public (hide)
(send this display "none"))
@@ -760,16 +832,28 @@
(define/public (show-inline)
(send this display "inline-block"))
(define/public (set-inner-html html-or-sexpr)
(if (string? html-or-sexpr)
(ww-set-inner-html win-id id html-or-sexpr)
(set-inner-html (xexpr->html5 html-or-sexpr))))
(super-new)
)
)
(define ww-clicker%
(class ww-base%
(define ww-input%
(class ww-element%
(define/public (get)
(ww-get-value (send this get-win-id) (send this get-id)))
(define/public (set! v)
(ww-set-value (send this get-win-id) (send this get-id) v))
(super-new)))
(define ww-window%
(class ww-base%
(class object%
(init-field [profile 'default-profile]
[parent-id #f]
@@ -784,34 +868,97 @@
)
(define win-id #f)
(define clickers (make-hash))
(define elements (make-hash))
(define (event-handler type evt content)
(displayln (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 '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))
(width* (string->number (cadr m)))
(height* (string->number (caddr m)))
)
(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)))
)
(set! x x*)
(set! y y*)
))
)
)
(define/public (handle-click element-id data)
(let ((el (hash-ref elements element-id #f)))
(unless (eq? el #f)
(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)))))
(define/public (get-win-id) win-id)
(define/public (bind-all)
(let ((button-ids (ww-bind win-id "click" "button")))
(for-each
(lambda (button-id)
(hash-set! clickers button-id
(new ww-clicker% [id button-id])))
button-ids))
(define/public (bind event selector cl)
(let ((ids (ww-bind win-id event selector)))
(for-each (λ (id)
(hash-set! elements id
(new cl [win-id win-id] [id id])))
ids)))
(ww-bind win-id "input" "input[type=text]")
(define/public (bind-inputs)
(bind 'change 'input ww-input%)
(bind 'change 'textarea ww-input%)
)
(define/public (handle-click content)
#t)
(define (event-handler evt content)
(displayln (format "win-id=~a '~a ~a" win-id evt content))
(cond
([eq? evt 'page-loaded] (send this bind-all))
([eq? evt 'click] (handle-click content))
)
(define/public (bind-buttons)
(bind 'click 'button ww-element%)
)
(define/public (element id)
(let ((el (hash-ref elements id #f)))
(if (eq? el #f)
(begin
(hash-set! elements id (new ww-element%
[win-id win-id] [id id]))
(element id))
el)))
(define/public (move x y)
(ww-move win-id x y))
(define/public (resize x y)
(ww-resize win-id x y))
(define/public (get-x) x)
(define/public (get-y) y)
(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)
(ww-set-title win-id t))
(define/public (get-title)
title)
(define/public (set-html-file! file)
(set! html-file file)
(ww-set-html win-id html-file))
(define/public (get-html-file)
html-file)
; construct
(begin
;(displayln (format "profile: ~a, ~a" profile parent-id))
@@ -821,7 +968,8 @@
(when (eq? win-id #f)
(error "Window could not be constructed"))
(hash-set! windows win-id event-handler)
(hash-set! windows-evt-handlers win-id (make-weak-box event-handler))
(hash-set! windows win-id (make-weak-box this))
(ww-move win-id x y)
(ww-resize win-id width height)
@@ -837,9 +985,16 @@
(unless (eq? html-file #f)
(ww-set-html win-id html-file))
(register-finalizer this
(λ (me)
(let ((win-id (send me get-win-id)))
(ww-close (send me get-win-id))
(hash-remove! windows win-id)
(hash-remove! windows-evt-handlers win-id)
)))
)
(super-new [id win-id])
(super-new)
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;