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

Need to provide examples.

Browse Source
This commit is contained in:
Hans Dijkema
2025-08-24 01:06:02 +02:00
parent 38fcf0265f
commit 1527026ad9
4 changed files with 707 additions and 329 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
example1/example.rkt Normal file
View File

@@ -0,0 +1 @@
#lang racket/gui

462
private/web-racket.rkt Normal file
View File

@@ -0,0 +1,462 @@
(module web-racket racket/gui
(require racket/gui
"web-wire.rkt"
"css.rkt"
html-printer
)
(provide ww-element%
ww-input%
ww-window%
ww-start
ww-stop
ww-set-debug
ww-debug
ww-error
(all-from-out "css.rkt")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define re-resize #px"([0-9]+)\\s+([0-9]+)")
(define re-move re-resize)
(define re-file-open #px"([0-9]+)[:]([^:]+)[:](.*)")
(define re-choose-dir re-file-open)
(define re-navigate #px"(.*)[:]([^:]+)$")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GUI classes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define _std_x 100)
(define _std_y 100)
(define _std_w 800)
(define _std_h 600)
(define (next-window-init-position)
(set! _std_x (+ _std_x 75))
(set! _std_y (+ _std_y 50))
(call-with-values
get-display-size
(lambda (w h)
(when (> (+ _std_y _std_h) h)
(set! _std_y 50))
(when (> (+ _std_x _std_w) w)
(set! _std_x 50))
)))
(define ww-element%
(class object%
(init-field [win-id #f] [id #f])
(define/public (get-win-id)
win-id)
(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)
(ww-error (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)
(send this add-class! 'disabled))
(define/public (disabled?)
(send this has-class? 'disabled))
(define/public (display . args)
(let ((d (if (null? args) "block" (car args))))
(send this add-style! (css-style 'display d))))
(define/public (hide)
(send this display "none"))
(define/public (show)
(send this display "block"))
(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-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))
(define/override (disable)
(super disable)
(ww-set-attr (send this get-win-id) (send this get-id) 'disabled ""))
(define/override (enable)
(super enable)
(ww-del-attr (send this get-win-id) (send this get-id) 'disabled))
(super-new)))
(define ww-input-date%
(class ww-input%
(define/override (get)
(let ((val (super get)))
val))
(super-new)
))
(define ww-window%
(class object%
(init-field [profile 'default-profile]
[parent-id #f]
[title "Racket HTML Window"]
[x _std_x]
[y _std_y]
[width _std_w]
[height _std_h]
[icon #f]
[menu #f]
[html-file #f]
)
(define win-id #f)
(define menu-cbs (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*)
))
([eq? evt 'request-close] (when (send this can-close?)
(send this close)))
([eq? evt 'menu-item-choosen] (let* ((menu-id (string->symbol content))
(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))))
(send this handle-navigate url type)))
)
)
(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 (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 (get-win-id) win-id)
(define (cl-selector tag type)
(cond
([eq? tag 'INPUT]
(cond
([eq? type 'text] ww-input%)
([eq? type 'date] ww-input-date%)
(else ww-input%)))
(else ww-element%)))
(define/public (bind event selector . forced-cl)
(let ((infos (ww-bind win-id event selector)))
(for-each (λ (info)
(let* ((id (car info))
(tag (cadr info))
(type (caddr info)))
(displayln (format "bind: ~a ~a ~a" id tag type))
(let ((cl (if (null? forced-cl)
(cl-selector tag type)
(car forced-cl))))
(hash-set! elements id
(new cl [win-id win-id] [id id])))))
infos)))
(define/public (bind-inputs)
(bind 'change 'input )
(bind 'change 'textarea)
)
(define/public (bind-buttons)
(bind 'click 'button)
)
(define/public (element id)
(let ((el (hash-ref elements id #f)))
(if (eq? el #f)
(let ((info (ww-element-info win-id id)))
(let* ((id (car info))
(tag (cadr info))
(type (caddr info))
(exist (cadddr info))
)
(unless exist
(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)))
(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 (set-url url)
(ww-set-url win-id url))
(define/public (get-html-file)
html-file)
(define/public (show)
(ww-set-show-state win-id 'show))
(define/public (hide)
(ww-set-show-state win-id 'hide))
(define/public (maximize)
(ww-set-show-state win-id 'maximize))
(define/public (normalize)
(ww-set-show-state win-id 'normalize))
(define/public (minimize)
(ww-set-show-state win-id 'minimize))
(define/public (fullscreen)
(ww-set-show-state win-id 'fullscreen))
(define/public (show-state)
(ww-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)
(when (= (hash-count windows) 0)
(ww-stop))
)
(define/public (set-menu menu-def)
(ww-set-menu win-id menu-def))
(define/public (connect-menu id cb)
(hash-set! menu-cbs id cb))
; files and directories
(define/public (file-open caption base-dir filters)
(let ((r (ww-file-open win-id caption base-dir filters)))
(if (eq? (car r) #f)
#f
(let ((m (regexp-match re-file-open (cdr r))))
(if (eq? m #f)
#f
(let ((file (cadddr m)))
(ww-from-string file))
)
)
)
)
)
(define/public (file-save caption base-dir filters . overwrite)
(let ((o (if (null? overwrite) #f (car overwrite))))
(let ((r (ww-file-save win-id caption base-dir filters o)))
(if (eq? (car r) #f)
#f
(let ((m (regexp-match re-file-open (cdr r))))
(if (eq? m #f)
#f
(let ((file (cadddr m)))
(ww-from-string file))
)
)
)
)
)
)
(define/public (choose-dir caption base-dir)
(let ((r (ww-choose-dir win-id caption base-dir)))
(if (eq? (car r) #f)
#f
(let ((m (regexp-match re-choose-dir (cdr r))))
(if (eq? m #f)
#f
(let ((dir (caddr m)))
(ww-from-string dir))
)
)
)
)
)
; construct
(begin
(when (= (hash-count windows) 0)
(ww-start))
(next-window-init-position)
(set! win-id (ww-new profile 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)
(ww-move win-id x y)
(ww-resize win-id width height)
(ww-set-title win-id title)
(unless (eq? icon #f)
(ww-set-icon win-id icon))
(unless (eq? menu #f)
(ww-set-menu win-id menu))
(unless (eq? html-file #f)
(ww-set-html win-id html-file))
)
(super-new)
))
(define (set-global-stylesheet st)
(ww-set-stylesheet st))
(define (get-global-stylesheet)
(ww-get-stylesheet))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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-window%
(class ww-window%
(super-new [html-file "../../web-wire/test/test1.html"])
(begin
(send this set-menu test-menu)
(send this connect-menu 'quit (λ () (send this close)))
)
))
); end of module

546
private/web-wire.rkt
View File

@@ -11,18 +11,68 @@
json
"../utils/utils.rkt"
"css.rkt"
html-printer
)
(provide ww-start
ww-stop
ww-set-debug
ww-debug
ww-error
ww-devtools
ww-cmd
ww-await
ww-set-stylesheet
ww-get-stylesheet
ww-new
ww-close
ww-move
ww-resize
ww-set-title
ww-set-icon
ww-set-menu
ww-set-html
ww-set-url
ww-set-inner-html
ww-get-inner-html
ww-set-attr
ww-get-attr
ww-del-attr
ww-set-style
ww-add-style
ww-get-style
ww-add-class
ww-remove-class
ww-has-class?
ww-set-value
ww-get-value
ww-set-show-state
ww-show-state
ww-bind
ww-on
ww-element-info
ww-file-open
ww-file-save
ww-choose-dir
windows
windows-evt-handlers
ww-from-string
)
(define current-win-release "https://github.com/hdijkema/web-wire/releases/download/0.1/web-wire-0.1-win64.zip")
@@ -107,7 +157,12 @@
#f)))
(define (as-string s)
(with-output-to-string (lambda () (write s))))
(let ((s* (format "~a" s)))
(with-output-to-string (lambda () (write s*)))))
(define (ww-from-string s)
(let ((s* (substring s 1 (- (string-length s) 1))))
(string-replace s* "\\\"" "\"")))
(define (to-server-file html-file)
(let* ((path (build-path html-file))
@@ -125,19 +180,22 @@
(define ww-from-ww #f)
(define ww-quit #f)
(define ww-debug #f)
(define _ww-debug #f)
(define (ww-set-debug yn) (set! ww-debug yn))
(define (ww-set-debug yn) (set! _ww-debug yn))
(define (do-debug str . var)
(when ww-debug
(when _ww-debug
(if (null? var)
(displayln (format "Debug: ~a" str))
(displayln (format "Debug: ~a: ~a" var str))
(displayln (format "Debug: ~a: ~a" (car var) str))
)))
(define (err str)
(displayln (format "Error: ~a" str)))
(define (err str . var)
(if (null? var)
(displayln (format "Error: ~a" str))
(displayln (format "Error: ~a: ~a" var str))
))
(define-syntax debug
(syntax-rules ()
@@ -147,6 +205,22 @@
(do-debug str 'var))
))
(define-syntax ww-debug
(syntax-rules ()
((_ str)
(do-debug str))
((_ var str)
(do-debug str 'var))
))
(define-syntax ww-error
(syntax-rules ()
((_ str)
(err str))
((_ var str)
(err str 'var))
))
(define re-kind #px"([A-Z]+)[(]([0-9]+)[)][:]")
(define re-event #px"([^:]+)[:]([0-9]+)([:](.*))?")
(define re-js-event #px"^([^:]+)([:](.*))?")
@@ -172,6 +246,7 @@
handle))))
(define (ww-start)
(ww-debug "ww-start called")
(define protocol-version 0)
@@ -184,13 +259,13 @@
(evt (string->symbol str-evt))
(win-id (string->number (caddr m)))
(content (car (cddddr m)))
(win* (hash-ref windows-evt-handlers win-id #f))
(win (if (eq? win* #f) #f (weak-box-value win*)))
(win (hash-ref windows-evt-handlers win-id #f))
)
;(debug content content)
(unless (or (eq? evt 'closed) (eq? evt 'js-result))
(if (eq? win #f)
(begin
(unless (or (eq? evt 'show-event)
(eq? evt 'hide-event))
(err (format "No such window ~a" win-id))
(err (format "Cannot handle event '~a " evt))
(err (format "input: ~a" line))
@@ -230,7 +305,9 @@
(when (eq? evt 'closed)
(if (eq? win #f)
(err (format "No such window ~a, cannot close" win-id))
(hash-remove! windows-evt-handlers win-id)))
(begin
(hash-remove! windows-evt-handlers win-id)
(hash-remove! windows win-id))))
))
))
@@ -324,37 +401,52 @@
(set! current-handle (+ current-handle 1))
current-handle)
(define (ww-cmd cmd)
(if (eq? cmd 'quit)
(begin
(displayln "exit" ww-to-ww)
(flush-output ww-to-ww)
(set! ww-quit #t))
(define (do-cmd cmd)
(if (eq? ww-to-ww #f)
(ww-error
(format "Unexpected: (eq? ww-to-ww #f), for command '~a'" cmd))
(begin
(displayln cmd ww-to-ww)
(flush-output ww-to-ww))
)
(let ((line-in (string-trim (read-line ww-from-ww))))
(let ((ok (string-prefix? line-in "OK("))
(nok (string-prefix? line-in "NOK("))
)
(let ((m (regexp-match re-kind line-in)))
(unless m
(error (format "Input not expected: ~a" line-in)))
(let* ((kind (cadr m))
(lines (string->number (caddr m)))
(result-str (substring line-in (string-length (car m))))
(more-lines (- lines 1))
)
;(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)))
(cons ok result-str)
))))
)
(define (ww-cmd cmd)
(if (eq? cmd 'quit)
(begin
(do-cmd "exit")
(set! ww-quit #t))
(begin
(do-cmd cmd))
)
(if (eq? ww-from-ww #f)
(begin
(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 ((ok (string-prefix? line-in "OK("))
(nok (string-prefix? line-in "NOK("))
)
(let ((m (regexp-match re-kind line-in)))
(unless m
(error (format "Input not expected: ~a" line-in)))
(let* ((kind (cadr m))
(lines (string->number (caddr m)))
(result-str (substring line-in (string-length (car m))))
(more-lines (- lines 1))
)
;(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)))
(cons ok result-str)
))))
)
)
(define (ww-await handle cmd)
@@ -385,6 +477,7 @@
;; Stop the QtWebEngine
(define (ww-stop)
(ww-debug "ww-stop called")
(let ((win-ids (hash-keys windows-evt-handlers)))
(for-each (λ (win-id)
(ww-close win-id))
@@ -392,6 +485,25 @@
(let ((r (ww-cmd 'quit)))
(car r)))
;; Global stylesheet
(define (ww-set-stylesheet st)
(let* ((css (if (stylesheet? st)
(stylesheet->string st)
st))
(h (let ((h (make-hasheq)))
(hash-set! h 'css css)
h))
(json (jsexpr->string h))
(cmd (format "set-stylesheet ~a" json))
)
(ww-cmd cmd)))
(define (ww-get-stylesheet)
(let ((cmd (format "get-stylesheet")))
(let ((r (ww-cmd cmd)))
(displayln r)
#t)))
;; Debug window
(define (ww-devtools win-id)
(let ((cmd (format "debug ~a" win-id)))
@@ -571,6 +683,12 @@
)
;; set url
(define (ww-set-url win-id url)
(let ((cmd (format "set-url ~a ~a ~a"
win-id (new-handle) (as-string url))))
(ww-cmd cmd)))
;; Set html of window
(define (ww-set-html win-id html-file)
@@ -613,8 +731,9 @@
;; Set attribute of element in html
(define (ww-set-attr win-id element-id attr val)
(let* ((js-handle (new-handle))
(cmd (format "set-attr ~a ~a ~a ~a" win-id js-handle
(as-string element-id) (as-string val))))
(cmd (format "set-attr ~a ~a ~a ~a ~a" win-id js-handle
(as-string element-id) (as-string attr) (as-string val))))
(displayln cmd)
(ww-cmd cmd)))
;; Get attribute value of element in html
@@ -627,8 +746,9 @@
;; 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))))
(cmd (format "del-attr ~a ~a ~a ~a" win-id js-handle
(as-string element-id)
(as-string attr))))
(ww-cmd cmd)))
;; get value of an element
@@ -654,7 +774,25 @@
(let* ((js-handle (new-handle))
(cmd (format "bind ~a ~a ~a ~a" win-id js-handle
(as-string event) (as-string selector))))
(map string->symbol (ww-await js-handle cmd))))
(map (lambda (info)
(map string->symbol info))
(ww-await js-handle cmd))))
(define (ww-on win-id event id)
(let* ((js-handle (new-handle))
(cmd (format "on ~a ~a ~a ~a"
win-id js-handle
(as-string event)
(as-string id))))
(ww-cmd cmd)))
;; Element info
(define (ww-element-info win-id id)
(let* ((js-handle (new-handle))
(cmd (format "element-info ~a ~a ~a" win-id js-handle
(as-string id))))
(ww-await js-handle cmd)))
;; Add a class to an element
(define (ww-add-class win-id element-id class)
@@ -721,295 +859,47 @@
)
(string->css-style (ww-await js-handle cmd))))
;; Show State
(define (ww-set-show-state win-id state)
(let ((cmd (format "set-show-state ~a ~a" win-id (as-string state))))
(ww-cmd cmd)))
(define (ww-show-state win-id)
(let ((cmd (format "show-state ~a" win-id)))
(ww-cmd cmd)))
;; Files and directories
(define (ww-file-open win-id title dir file-filters)
(let ((cmd (format "file-open ~a ~a ~a ~a" win-id
(as-string title)
(as-string dir)
(as-string file-filters))))
(ww-cmd cmd)))
(define (ww-file-save win-id title dir file-filters overwrite)
(let ((cmd (format "file-save ~a ~a ~a ~a ~a" win-id
(as-string title)
(as-string dir)
(as-string file-filters)
(if overwrite 1 0))))
(ww-cmd cmd)))
(define (ww-choose-dir win-id title dir)
(let ((cmd (format "choose-dir ~a ~a ~a" win-id
(as-string title)
(as-string dir))))
(ww-cmd cmd)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Finalizing stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define will (make-will-executor))
;(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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define _std_x 100)
(define _std_y 100)
(define _std_w 800)
(define _std_h 600)
(define (next-window-init-position)
(set! _std_x (+ _std_x 75))
(set! _std_y (+ _std_y 50))
(call-with-values
get-display-size
(lambda (w h)
(when (> (+ _std_y _std_h) h)
(set! _std_y 50))
(when (> (+ _std_x _std_w) w)
(set! _std_x 50))
)))
(define ww-element%
(class object%
(init-field [win-id #f] [id #f])
(define/public (get-win-id)
win-id)
(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)
(send this add-class! 'disabled))
(define/public (disabled?)
(send this has-class? 'disabled))
(define/public (display . args)
(let ((d (if (null? args) "block" (car args))))
(send this add-style! (css-style 'display d))))
(define/public (hide)
(send this display "none"))
(define/public (show)
(send this display "block"))
(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-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 object%
(init-field [profile 'default-profile]
[parent-id #f]
[title "Racket HTML Window"]
[x _std_x]
[y _std_y]
[width _std_w]
[height _std_h]
[icon #f]
[menu #f]
[html-file #f]
)
(define win-id #f)
(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 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)))
(define/public (bind-inputs)
(bind 'change 'input ww-input%)
(bind 'change 'textarea ww-input%)
)
(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))
(next-window-init-position)
(set! win-id (ww-new profile parent-id))
(when (eq? win-id #f)
(error "Window could not be constructed"))
(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)
(ww-set-title win-id title)
(unless (eq? icon #f)
(ww-set-icon win-id icon))
(unless (eq? menu #f)
(ww-set-menu win-id menu))
(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)
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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-window%
(class ww-window%
(super-new [html-file "../../web-wire/test/test1.html"])))
;(define (ww-register-finalizer obj proc)
; (will-register will obj proc))
;(void (thread (λ () (let loop () (will-execute will) (loop)))))
); end of module

25
private/wr-test1.rkt Normal file
View File

@@ -0,0 +1,25 @@
#lang racket/gui
(require "web-racket.rkt"
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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-window%
(class ww-window%
(super-new [html-file "../../web-wire/test/test1.html"])
(begin
(set-menu test-menu)
)
))
); end of module