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

more devel

Browse Source
This commit is contained in:
Hans Dijkema
2025-08-22 01:35:57 +02:00
parent 30e95c5a64
commit 02890d0a26
3 changed files with 919 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
info.rkt Normal file
View File

@@ -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"
))

860
private/web-wire.rkt
View File

@@ -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

65
utils/utils.rkt Normal file
View File

@@ -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