From 02890d0a267d45c6720bd1275037a658d4fcba51 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Fri, 22 Aug 2025 01:35:57 +0200 Subject: [PATCH] more devel --- info.rkt | 23 ++ private/web-wire.rkt | 860 +++++++++++++++++++++++++++++++++++++++++-- utils/utils.rkt | 65 ++++ 3 files changed, 919 insertions(+), 29 deletions(-) create mode 100644 info.rkt create mode 100644 utils/utils.rkt diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..afa7fb7 --- /dev/null +++ b/info.rkt @@ -0,0 +1,23 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.1.0") +(define license 'GPL-3.0-or-later) ; The liboa library has this license +(define collection "web-racket") +(define pkg-desc "web-racket - A Web Based GUI library, based on web-wire") + +(define scribblings + '( + ("scribblings/web-racket.scrbl" () (gui-library) "web-racket") + ) + ) + +(define deps + '("racket/base" "net/http-easy" "file/unzip")) + +(define build-deps + '("racket-doc" + "draw-doc" + "rackunit-lib" + "scribble-lib" + )) diff --git a/private/web-wire.rkt b/private/web-wire.rkt index e532075..67ef496 100644 --- a/private/web-wire.rkt +++ b/private/web-wire.rkt @@ -1,58 +1,860 @@ (module web-wire racket/base (require racket/system + racket/file + racket/gui + racket/port + file/unzip + net/url + racket/port + roos + data/queue + json + "../utils/utils.rkt" ) (provide ww-start - ww ww-stop + ww-set-debug ww-new ww-move ww-resize ww-set-title ww-set-icon + + ) - (define current-win-release " + (define current-win-release "https://github.com/hdijkema/web-wire/releases/download/0.1/web-wire-0.1-win64.zip") - (define ww-thread #f); + (define (os) + (format "~a-~a" (system-type) (system-type 'word))) + + (define (web-wire-exe) + (if (eq? (system-type) 'windows) + "web-wire.exe" + "web-wire")) + + (define (web-wire-dir) + (let* ((cache-dir (find-system-path 'cache-dir)) + (os-dir (build-path cache-dir (os)))) + os-dir)) + + (define (do-download-and-extract release version os-dir) + (let* ((url (string->url release)) + (port-in (get-pure-port url #:redirections 10)) + (release-file (build-path os-dir "release.zip")) + (port-out (open-output-file release-file #:exists 'replace)) + ) + (letrec ((f (lambda (count next-c len) + (let ((bytes (read-bytes 16384 port-in))) + (if (eof-object? bytes) + count + (let ((read-len (bytes-length bytes))) + (when (> read-len 0) + (set! count (+ count read-len)) + (when (> count next-c) + (display (format "~a..." count)) + (set! next-c (+ count len))) + (write-bytes bytes port-out) + ) + (f count next-c len))))) + )) + (display "Downloading web-wire...") + (let ((count (f 0 0 10000000))) + (displayln (format "~a downloaded" count))) + (close-input-port port-in) + (close-output-port port-out) + (display "Unzipping...") + (unzip release-file + (make-filesystem-entry-reader #:dest os-dir + #:strip-count 1 + #:exists 'replace) + ) + (display "removing zip file...") + (delete-file release-file) + (displayln "done") + ))) + + (define (download-if-needed release) + (let* ((os-dir (web-wire-dir)) + (re #px"web[-]wire[-]([0-9.]+)[-]") + ) + (unless (directory-exists? os-dir) + (make-directory* os-dir)) + (let ((m (regexp-match re release))) + (unless (eq? m #f) + (let* ((version-file (build-path os-dir "version")) + (version (cadr m)) + (has-version #f)) + (when (file-exists? version-file) + (let ((file-version (file->value version-file))) + (when (string=? file-version version) + (set! has-version #t)))) + (unless has-version + (do-download-and-extract release version os-dir) + (write-to-file version version-file) + )) + )))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Some utils + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (drop expected s) + (let ((e (string-append expected ":"))) + (if (string-prefix? s e) + (substring s (string-length e)) + #f))) + + (define (as-string s) + (with-output-to-string (lambda () (write s)))) + + (define (to-server-file html-file) + (let* ((path (build-path html-file)) + (complete-p (path->complete-path path)) + (a-file (format "~a" complete-p)) + (the-file (string-replace a-file "\\" "/"))) + the-file)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; web-wire handling + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define ww-err-thread #f) + (define ww-to-ww #f) + (define ww-from-ww #f) + (define ww-quit #f) + + (define ww-debug #f) + (define (ww-set-debug yn) + (set! ww-debug yn)) + + (define (debug str) + (when ww-debug + (displayln str))) + + (define (err str) + (displayln (format "Error: ~a" str))) + + (define re-kind #px"([A-Z]+)[(]([0-9]+)[)][:]") + (define re-event #px"([^:]+)[:]([0-9]+)([:](.*))?") + (define re-js-result #px"([0-9]+)[:]([^:]+)[:](.*)") + (define re-js-handle #px"([^:]+)[:]([0-9]+)[:]([0-9]+)([:](.*))?") + + (define windows (make-hash)) + + (define handle-results (make-hash)) + (define handle-semaphores (make-hash)) + + (define (ww-get-js-handle r) + (let* ((h-info (cdr r)) + (m (regexp-match re-js-handle h-info))) + (if (eq? m #f) + #f + (let* ((kind (string->symbol (cadr m))) + (win (string->number (caddr m))) + (handle (string->number (cadddr m))) + (rest (car (cddddr m))) + ) + handle)))) (define (ww-start) - (if (eq? ww-thread #f) - (let ((cwd (current-directory) - (let* ((cwd (current-directory)) - (bin (build-path cwd ".." "bin" "linux" "web-wire")) - (ww (make-ww)) - (ports (process bin))) - (let* ((in (car ports)) - (out (cadr ports)) - (pid (caddr ports)) - (err (cadddr ports)) + + (define protocol-version 0) + + (define (handle-event 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))) + (win-id (string->number (caddr m))) + (content (car (cddddr m))) + (win (hash-ref windows win-id #f)) + ) + (unless (or (eq? evt 'closed) (eq? evt 'js-result)) + (if (eq? win #f) + (begin + (err (format "No such window ~a" win-id)) + (err (format "Cannot handle event '~a" evt)) + (err (format "input: ~a" line)) + ) + (queue-callback (lambda () + (win evt content))) + )) + (when (eq? evt 'js-result) + (let ((m (regexp-match re-js-result content))) + (if (eq? m #f) + (err (format "Cannot interpret js-result: ~a" content)) + (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)) + ) + ;(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) + (semaphore-post (hash-ref handle-semaphores handle))) + (debug (format "not awaiting ~a: ~a" handle content))) + ) + ))) + (when (eq? evt 'closed) + (if (eq? win #f) + (err (format "No such window ~a, cannot close" win-id)) + (hash-remove! windows win-id))) + )) + )) + + (define (web-wire-err-handler err-ww) + (let* ((line-in (read-line err-ww)) + (go-on #t)) + (while (and (not ww-quit) (not (eof-object? line-in))) + (let* ((line (string-trim line-in)) + (m (regexp-match re-kind line)) + ) + (if (eq? m #f) + (debug line) + (let* ((kind (string->symbol (cadr m))) + (lines (string->number (caddr m))) + (rest (substring line (string-length (car m)))) + (more-lines (- lines 1)) + ) + (while (> more-lines 0) + (let ((line (string-trim (read-line err-ww)))) + (set! rest (string-append rest "\n" line)) + (set! more-lines (- more-lines 1)) + )) + (cond + ([eq? kind 'EVENT] (handle-event rest)) + (else (debug (format "~a(~a):~a" kind lines rest))) + )) + )) + (set! line-in (read-line err-ww)))) + #t) + + (define (web-wire-proc-control p-c from-ww to-ww err-ww) + (let ((status (p-c 'status))) + (while (eq? status 'running) + (sleep 1) + (set! status (p-c 'status))) + (p-c 'wait) + (close-input-port from-ww) + (close-output-port to-ww) + (close-input-port err-ww) + (set! ww-to-ww #f) + (set! ww-from-ww #f) + (set! ww-err-thread #f) + (set! ww-quit #f) + )) + + (if (eq? ww-err-thread #f) + (begin + ;; Maybe we need to download the web-wire executable + (let* ((os (system-type)) + (release (cond + ([eq? os 'windows] current-win-release) + (else #f)))) + (unless (eq? release #f) + (download-if-needed release))) + + ;; Start the web-wire process for errors and events in an other thread + (let ((cwd (current-directory))) + (current-directory (web-wire-dir)) + (let ((ports (process (web-wire-exe)))) + (current-directory cwd) + (let ((from-ww (car ports)) + (to-ww (cadr ports)) + (ww-pid (caddr ports)) + (err-from-ww (cadddr ports)) + (proc-control (car (cddddr ports))) + ) + + (set! ww-to-ww to-ww) + (set! ww-from-ww from-ww) + (set! ww-quit #f) + + (parameterize ([current-eventspace (current-eventspace)]) + (set! ww-err-thread + (thread (lambda () (web-wire-err-handler err-from-ww)))) + (thread (lambda () (web-wire-proc-control proc-control + from-ww + to-ww err-from-ww))) + ) + ww-pid + ))) + ) + #f)) + + (define current-handle 0) + + (define (new-handle) + (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)) + (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-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)) + (result (car r)) + (content (cdr r)) + ) + (if r + (begin + (semaphore-wait (hash-ref handle-semaphores handle)) + (hash-remove! handle-semaphores handle) + (let ((r (hash-ref handle-results handle))) + (hash-remove! handle-results handle) + (continuation r))) + (begin + (hash-remove! handle-semaphores handle) + (hash-remove! handle-results handle) + (continuation #f)) + ) + ) + ) ) - (set-ww-process-handler! (thread - (displayln bin) - (let ((ports (process bin))) - - #t)) + ) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Web Wire Commands + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Stop the QtWebEngine (define (ww-stop) - #t) + (let ((r (ww-cmd 'quit))) + (car r))) - (define (ww-new) - #t) + ;; Debug window + (define (ww-devtools win-id) + (let ((cmd (format "debug ~a" win-id))) + (ww-cmd cmd))) + + ;; New window + (define (ww-new profile . parent) + (let* ((parent-win-id (if (null? parent) + "" + (if (eq? (car parent) #f) + "" + (format " ~a" (car parent))))) + (cmd (string-append "new " (format "~a" profile) parent-win-id)) + (r (ww-cmd cmd))) + (let ((ok (car r)) + (res (cdr r))) + (if ok + (let* ((win-str-id (drop "new" res)) + (win-id (if (eq? win-str-id #f) #f (string->number win-str-id))) + ) + win-id) + #f)))) - (define (ww-move) - #t) + ;; Close window + (define (ww-close win-id) + (let ((r (ww-cmd (format "close ~a" win-id)))) + (car r))) - (define (ww-resize) - #t) + ;; Move window + (define (ww-move win-id x y) + (let ((r (ww-cmd (format "move ~a ~a ~a" win-id x y)))) + (car r))) - (define (ww-set-title) - #t) + ;; Resize window + (define (ww-resize win-id width height) + (let ((r (ww-cmd (format "resize ~a ~a ~a" win-id width height)))) + (car r))) - (define (ww-set-icon) - #t) + ;; Set title of window + (define (ww-set-title win-id title) + (let ((r (ww-cmd (format "set-title ~a ~a" win-id (as-string title))))) + (car r))) + + ;; Set icon of window + (define (ww-set-icon win-id file) + (if (file-exists? file) + (let* ((icon-file (to-server-file file)) + (cmd (format "set-icon ~a ~a" + win-id (as-string (format "~a" icon-file)))) + (r (ww-cmd cmd))) + (car r)) + (error "ww-set-icon - file does not exist"))) + + ;; Set menu of window + (define (ww-set-menu win-id menu-list) + + (define (atom? e) (not (pair? e))) + + (define (is-simple-entry-form? e) + (if (= (length e) 2) + (if (atom? (car e)) + (let ((r (cdr e))) + (if (atom? r) + #t + (if (list? r) + (if (= (length r) 1) + (if (atom? (car r)) + #t + (if (list? (car r)) + (if (null? (car r)) + #f + (atom? (caar r))) + (atom? (car r))) + ) + #f) + #f) + ) + ) + #f) + #f) + ) + + (define (is-simple-entry? e) + (if (= (length e) 2) + (if (string? (car e)) + (let ((r (cdr e))) + (if (symbol? r) + #t + (if (list? r) + (if (= (length r) 1) + (if (symbol? (car r)) + #t + (if (list? (car r)) + (if (null? (car r)) + #f + (symbol? (caar r))) + (symbol? (car r)))) + #f) + #f) + )) + #f) + #f)) + + ; Pre: (is-simple-entry? e) + (define (cvt-simple-entry e) + (let ((s (car e)) + (r (cdr e))) + (if (symbol? r) + (list s r) + (if (symbol? (car r)) + (list s (car r)) + (list s (caar r))) + )) + ) + + (define (pair->list p) + (if (pair? p) + (let* ((rest (cdr p)) + (s (car p)) + (r (list s rest))) + (if (is-simple-entry? r) + (cvt-simple-entry r) + (if (list? (car rest)) + (if (is-simple-entry? (car rest)) + r + (list s (car rest))) + r))) + p)) + + (define (is-submenu? e) + (if (= (length e) 2) + (not (is-simple-entry? e)) + #t)) + + (define (cvt-submenu e) + (if (list? e) + (if (= (length e) 1) + (if (is-simple-entry? (car e)) + e + (car e)) + e) + e)) + + (define (cvt-menu-list l) + (map (lambda (e) + ;(displayln e) + (unless (or (pair? e) (list? e)) + (error "Unexpected item: ~a" e)) + (let ((e* (pair->list e))) + (if (is-simple-entry? e*) + (cvt-simple-entry e*) + (if (is-simple-entry-form? e*) + (error (format "Menu entry must be '(title: string id:symbol), got ~a" e)) + (if (is-submenu? e*) + (list (car e*) (cvt-menu-list (cvt-submenu (cdr e*)))) + (error (format "Unknown menu entry: ~a" e)) + ))))) + l)) + + (define (to-json-menu l) + (map (lambda (e) + (if (is-simple-entry? e) + (list (car e) (symbol->string (cadr e))) + (list (car e) (to-json-menu (cadr e))))) + l)) + + (unless (list? menu-list) + (error "A menu list must contain menu entries (pairs/lists of string + symbol/submenu lists)")) + (let ((ml (cvt-menu-list menu-list))) + (let ((jml (to-json-menu ml))) + (let* ((json-menu (with-output-to-string (lambda () (write-json jml)))) + (as-str (with-output-to-string (lambda () (write json-menu)))) + (cmd (format "set-menu ~a ~a" win-id as-str))) + (let ((r (ww-cmd cmd))) + (car r))))) + ) + + + + ;; Set html of window + (define (ww-set-html win-id html-file) + (if (file-exists? html-file) + (let ((cmd (format "set-html ~a ~a ~a" + win-id (new-handle) + (as-string (to-server-file html-file))))) + (let ((r (ww-cmd cmd))) + (car r))) + (error "set-html: file does not exist") + )) + + ;; Set inner html of an Id of the HTML in the window + (define (ww-set-inner-html win-id element-id html-or-file) + (if (file-exists? html-or-file) + (let* ((js-handle (new-handle)) + (cmd (format "set-inner-html ~a ~a ~a ~a" + win-id js-handle + (format "~a" element-id) + (as-string (to-server-file html-or-file)))) + ) + (ww-await js-handle cmd)) + (let* ((js-handle (new-handle)) + (cmd (format "set-inner-html ~a ~a ~a ~a" + win-id js-handle + (format "~a" element-id) + (as-string (format "~a" html-or-file)))) + ) + (ww-await js-handle cmd)) + )) + + ;; Het the inner html of an id of the HTML in the window + (define (ww-get-inner-html win-id element-id) + (let* ((js-handle (new-handle)) + (cmd (format "get-inner-html ~a ~a ~a" + win-id js-handle (format "~a" element-id))) + ) + (ww-await js-handle cmd))) + + ;; 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)))) + (ww-cmd cmd))) + + ;; 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 + (as-string element-id)))) + (ww-await js-handle cmd))) + + + ;; Bind some CSS selector to an event, given that each + ;; element that satisfies the selector has to have an id. + ;; Returns the element ids as symbols + (define (ww-bind win-id event selector) + (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)))) + + ;; Add a class to an element + (define (ww-add-class win-id element-id class) + (let* ((js-handle (new-handle)) + (cmd (format "add-class ~a ~a ~a ~a" win-id js-handle + (as-string element-id) (as-string class))) + ) + (ww-cmd cmd))) + + ;; Remove a class from an element + (define (ww-remove-class win-id element-id class) + (let* ((js-handle (new-handle)) + (cmd (format "remove-class ~a ~a ~a ~a" win-id js-handle + (as-string element-id) (as-string class))) + ) + (ww-cmd cmd))) + + ;; 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"))) + (if (eq? cl #f) + #f + (let* ((cls (regexp-split re-class-split cl))) + (letrec ((f (lambda (cls) + (if (null? cls) + #f + (let ((cl (car cls))) + (if (string=? cl class) + #t + (f (cdr cls)))) + )) + )) + (f cls))) + ) + ) + ) + + ;; 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)) + (js-handle (new-handle)) + (cmd (format "add-style ~a ~a ~a ~a" win-id js-handle + (as-string element-id) (as-string st))) + ) + (ww-cmd cmd))) + + ;; Set a style of an element + (define (ww-set-style win-id element-id css-style) + (let* ((st (mk-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))) + ) + (ww-cmd cmd))) + + ;; Get the style of an element + (define (ww-get-style win-id element-id) + (let* ((js-handle (new-handle)) + (cmd (format "get-style ~a ~a ~a" win-id js-handle + (as-string element-id))) + ) + (split-style-string (ww-await js-handle cmd)))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; 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-base% + (class object% + (init-field [win-id #f] [id #f]) + + (define/public (enable) + (ww-remove-class win-id id 'disabled)) + + (define/public (enabled) + (not (ww-has-class? win-id id 'disabled))) + + (define/public (disable) + (ww-add-class win-id id 'disabled)) + + (define/public (disabled) + (ww-has-class? win-id id 'disabled)) + + (define/public (display . args) + (let ((d (if (null? args) "block" (car args)))) + (ww-add-style win-id id (list (cons '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")) + + (super-new) + ) + ) + + (define ww-clicker% + (class ww-base% + (super-new))) + + (define ww-window% + (class ww-base% + + (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 clickers (make-hash)) + + (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)) + + (ww-bind win-id "input" "input[type=text]") + ) + + (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)) + ) + ) + + ; 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 win-id event-handler) + + (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 [id win-id]) + )) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; 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"]))) + + ); end of module \ No newline at end of file diff --git a/utils/utils.rkt b/utils/utils.rkt new file mode 100644 index 0000000..93cc9fc --- /dev/null +++ b/utils/utils.rkt @@ -0,0 +1,65 @@ +(module utils racket/base + + (provide while + until + get-lib-path + do-for + ) + + (define-syntax while + (syntax-rules () + ((_ cond body ...) + (letrec ((while-f (lambda (last-result) + (if cond + (let ((last-result (begin + body + ...))) + (while-f last-result)) + last-result)))) + (while-f #f)) + ) + )) + + (define-syntax until + (syntax-rules () + ((_ cond body ...) + (letrec ((until-f (lambda (last-result) + (if cond + last-result + (let ((last-reult (begin + body + ...))) + (until-f last-result)))))) + (until-f #f))))) + + (define-syntax do-for + (syntax-rules () + ((_ (init cond next) body ...) + (begin + init + (letrec ((do-for-f (lamba () + (if cond + (begin + (begin + body + ...) + next + (do-for-f)))))) + (do-for-f)))))) + + (define (get-lib-path lib) + (let ((platform (system-type))) + (cond + [(eq? platform 'windows) + (let ((try1 (build-path (current-directory) ".." "lib" "dll" lib)) + (try2 (build-path (current-directory) "lib" "dll" lib))) + (if (file-exists? try1) + try1 + try2) + )] + [else + (error (format "Install the shared library: ~a" lib))] + ))) + + + ) ; end of module