diff --git a/info.rkt b/info.rkt index afa7fb7..350cc64 100644 --- a/info.rkt +++ b/info.rkt @@ -13,7 +13,7 @@ ) (define deps - '("racket/base" "net/http-easy" "file/unzip")) + '("racket/base" "net/http-easy" "file/unzip" "gregor" "html-printer")) (define build-deps '("racket-doc" diff --git a/lib/dll/libwebui-wire.dll b/lib/dll/libwebui-wire.dll new file mode 100644 index 0000000..d22cf42 Binary files /dev/null and b/lib/dll/libwebui-wire.dll differ diff --git a/private/css.rkt b/private/css.rkt index a0523e5..b30caf0 100644 --- a/private/css.rkt +++ b/private/css.rkt @@ -31,13 +31,15 @@ ( [style #:auto #:mutable] ) - #:auto-value (make-hash)) + #:auto-value (make-hash) + #:transparent) (define-struct css-stylesheet ( [sheet #:auto #:mutable] ) - #:auto-value (make-hashalw)) + #:auto-value (make-hashalw) + #:transparent) (define st-style style-style) (define make-st make-style) diff --git a/private/web-racket.rkt b/private/web-racket.rkt index 1c1ef9c..7e2a490 100644 --- a/private/web-racket.rkt +++ b/private/web-racket.rkt @@ -3,7 +3,11 @@ (require racket/gui "web-wire.rkt" "css.rkt" + "../utils/sprintf.rkt" html-printer + (prefix-in g: gregor) + (prefix-in g: gregor/time) + gregor-utils ) (provide ww-element% @@ -50,6 +54,11 @@ (set! _std_x 50)) ))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Class representing an element in the HTML page + ;; each element is identified by an id. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define ww-element% (class object% (init-field [win-id #f] [id #f]) @@ -144,32 +153,126 @@ ) ) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Classes representing different kinds of input/textarea elements in html + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define-syntax inp-set! + (syntax-rules () + ((_ var val) + (set! var val)))) + + + ;;;; Generic input (define ww-input% (class ww-element% + (define val #f) + (define/public (get) - (ww-get-value (send this get-win-id) (send this get-id))) + val) (define/public (set! v) - (ww-set-value (send this get-win-id) (send this get-id) v)) + (inp-set! val 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 "")) + (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)) + (ww-del-attr (send this get-win-id) + (send this get-id) 'disabled)) + (super-new) + + (begin + (inp-set! val (ww-get-value (send this get-win-id) + (send this get-id))) + (send this connect 'input (λ (data) + (inp-set! val (hash-ref data 'value)))) + (send (send this win) bind 'input (format "#~a" (send this get-id))) + ) + )) + + + ;;;; Email input + (define ww-input-email% + (class ww-input% + (super-new))) + ;;;; Date input (define ww-input-date% (class ww-input% (define/override (get) (let ((val (super get))) - val)) + (g:parse-date val "yyyy-MM-dd"))) + (define/override (set! d) + (when (racket-date? d) + (set! (date->moment d))) + (unless (or (g:date? d) (g:moment? d) (g:datetime? d)) + (error "set! - gregor date expected")) + (super set! (sprintf "%04d-%02d-%02d" (g:->year d) (g:->month d) (g:->day d))) + d) + + (super-new) + )) + + ;;;; Time input + + (define ww-input-time% + (class ww-input% + + (define/override (get) + (let ((val (super get))) + (with-handlers ([exn:fail? + (λ (e) (g:parse-time val "HH:mm"))]) + (g:parse-time val "HH:mm:ss")))) + + (define/override (set! t) + (when (racket-date? t) + (set! (date->moment t))) + (unless (or (g:time? t) (g:datetime? t) (g:moment? t)) + (error "set! - gregor time?, moment? or datetime? expected")) + (super set! (sprintf "%02d:%02d:%02d" (g:->hours t) (g:->minutes t) (g:->seconds t)))) + + (super-new) + )) + + ;;;;; Date-time local + (define ww-input-datetime% + (class ww-input% + + (define/override (get) + (let ((val (super get))) + (with-handlers ([exn:fail? + (λ (e) (g:parse-moment val "yyyy-MM-dd'T'HH:mm:ss"))]) + (g:parse-moment val "yyyy-MM-dd'T'HH:mm")))) + + (define/override (set! m) + (when (racket-date? m) + (set! date->moment m)) + (unless (or (g:datetime? m) (g:moment? m) (g:date? m) (g:time? m)) + (error "set! - gregor time? , date?, datetime? or moment? expected")) + #t) + + (super-new) + ) + ) + + ;;;; Range + (define ww-input-range% + (class ww-input% + + (define/override (get) + (let ((val (super get))) + val)) (super-new) )) @@ -199,6 +302,7 @@ (cond ([eq? evt 'page-loaded] (send this html-loaded)) ([eq? evt 'click] (handle-click (car content) (cadr content))) + ([eq? evt 'input] (handle-input (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))) @@ -238,6 +342,11 @@ (unless (eq? el #f) (send el callback 'change (hash-ref data 'value))))) + (define/public (handle-input element-id data) + (let ((el (hash-ref elements element-id #f))) + (unless (eq? el #f) + (send el callback 'input data)))) + (define/public (handle-navigate url type kind) (let ((method (if (eq? kind 'set-html) 'set-html-file! 'set-url))) (cond @@ -256,10 +365,12 @@ (cond ([eq? type 'text] ww-input%) ([eq? type 'date] ww-input-date%) + ([eq? type 'datetime-local] ww-input-datetime%) (else ww-input%))) (else ww-element%))) (define/public (bind event selector . forced-cl) + (ww-debug (format "call to bind ~a ~a ~a" event selector forced-cl)) (let ((infos (ww-bind win-id event selector))) (for-each (λ (info) (let* ((id (car info)) @@ -269,8 +380,10 @@ (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]))))) + (unless (hash-has-key? elements id) + (hash-set! elements id 'in-the-making) + (hash-set! elements id + (new cl [win-id win-id] [id id])))))) infos))) (define/public (bind-inputs) @@ -283,22 +396,22 @@ ) (define/public (element id) - (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* ((el-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 el-id obj) - )) - (element id)) - el))) + (unless (hash-has-key? elements id) + (let ((info (ww-element-info win-id id))) + (let* ((el-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 el-id obj) + )) + (element id)) + ) + (hash-ref elements id)) (define/public (get-elements selector) (ww-get-elements win-id selector)) diff --git a/private/web-wire.rkt b/private/web-wire.rkt index 61d3e10..ac380fa 100644 --- a/private/web-wire.rkt +++ b/private/web-wire.rkt @@ -11,6 +11,7 @@ json "../utils/utils.rkt" "css.rkt" + "webui-wire-ffi.rkt" ) (provide ww-start @@ -246,7 +247,7 @@ )) (define re-kind #px"([A-Z]+)[(]([0-9]+)[)][:]") - (define re-event #px"([^:]+)[:]([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]+)([:](.*))?") @@ -272,6 +273,7 @@ ) handle)))) + #| (define (ww-start) (ww-debug "ww-start called") @@ -433,7 +435,101 @@ (define (new-handle) (set! current-handle (+ current-handle 1)) current-handle) + |# + (define-struct web-rkt + ([handle #:mutable] + [event-and-log-thread #:mutable] + [stop-thread #:mutable] + ) + ) + + (define ww-current-handle #f) + + (define log-fifo (make-queue)) + (define log-fifo-max 100) + + (define re-event #px"^([^:]+)([:]([^:]+))?") + + (define (process-event h evt) + (let ((m (regexp-match re-event evt))) + (displayln evt) + (let* ((e (string->symbol (string-downcase (list-ref m 1)))) + (win-id (if (eq? (list-ref m 3) #f) #f (string->number (list-ref m 3)))) + (win (hash-ref windows-evt-handlers win-id #f)) + (payload (substring evt (string-length (list-ref m 0)))) + ) + (if (eq? win #f) + (displayln (format "no window to handle event ~a" evt)) + (win e payload))))) + + (define (process-log h kind msg) + (unless (< (queue-length log-fifo) log-fifo-max) + (dequeue! log-fifo) + (process-log h kind msg)) + (enqueue! log-fifo (cons kind msg))) + + (define (ww-display-log) + (for-each (λ (item) + (displayln (format "~a - ~a" (car item) (cdr item)))) + (queue->list log-fifo))) + + (define (event-and-log-handler h) + (parameterize ([current-eventspace (current-eventspace)]) + (let ((ww-h (web-rkt-handle h))) + (thread + (lambda () + (letrec ((f (lambda () + (let* ((count (webwire-items ww-h)) + (item (if (= count 0) + '(null) ; If we know the count to be 0, we don't wait on a semaphore in the C library (will block racket). + (webwire-get ww-h))) + (info (car item))) + (cond + ([eq? info 'invalid-handle] + 'invalid-handle) + ([eq? info 'null] + (sleep 0.1) ; give others room to do something + (f)) + ([eq? info 'event] + (begin + (process-event h (cadr item)) + (f))) + ([eq? info 'log] + (begin + (process-log h (caddr item) (cadddr item)) + (f))) + ) + ))) + ) + (f)) + )) + )) + ) + + (define (ww-start) + (when (eq? ww-current-handle #f) + (let ((existing-h (webwire-current))) + (let ((h (make-web-rkt (if (eq? existing-h #f) + (webwire-new) + existing-h) + #f + #f))) + (unless (eq? (webwire-status (web-rkt-handle h)) 'valid) + (error (format "Invalid handle, cannot start. Reason: ~a" + (webwire-status->string + (webwire-status (web-rkt-handle h)))))) + (let ((thrd (event-and-log-handler h))) + (set-web-rkt-event-and-log-thread! h thrd) + (set! ww-current-handle h))))) + ww-current-handle) + + (define (ww-stop) + (unless (eq? ww-current-handle #f) + (webwire-destroy (web-rkt-handle ww-current-handle)) + (set! ww-current-handle #f))) + + #| (define (do-cmd cmd) (if (eq? ww-to-ww #f) (ww-error @@ -443,7 +539,64 @@ (flush-output ww-to-ww)) ) ) - + |# + + (define-struct cmdr + (ok kind win r)) + + (define (cmdr->list r) + (list (cmdr-ok r) (cmdr-kind r) + (cmdr-win r) (cmdr-r r))) + + (define (cmdr-dbg r) + (displayln (cmdr->list r))) + + + (define re-generic-result #px"^(OK|NOK)[:]([^:]+)([:]([0-9]+))?") + + (define (convert-result result) + (let ((m (regexp-match re-generic-result result))) + (displayln result) + (displayln m) + (if m + (let* ((ok (string=? (list-ref m 1) "OK")) + (kind (list-ref m 2)) + (win (if (eq? (list-ref m 4) #f) + #f + (string->number (list-ref m 4)))) + (r (substring result (string-length (list-ref m 0)))) + ) + (make-cmdr ok (string->symbol kind) + win + (if (string-prefix? r ":") + (substring r 1) + r))) + (make-cmdr #f 'parse-error #f result)) + ) + ) + + (define (check-nok cmd r) + (when (eq? (cmdr-ok r) #f) + (process-log ww-current-handle 'CMD-NOK + (format "~a - ~a" cmd (cmdr->list r))))) + + + (define (ww-cmd cmd) + (if (eq? cmd 'quit) + (let ((result (webwire-command (web-rkt-handle ww-current-handle) "exit"))) + (let ((r (convert-result result))) + (check-nok cmd r) + (ww-stop) + (set! ww-quit #t) + r)) + (let ((result (webwire-command (web-rkt-handle ww-current-handle) cmd))) + (let ((r (convert-result result))) + (check-nok cmd r) + r)))) + + + (define ww-await (lambda x #t)) + #| (define (ww-cmd cmd) (if (eq? cmd 'quit) @@ -493,7 +646,9 @@ ) ) - (define (ww-await handle cmd) + |# + + #|(define (ww-await handle cmd) (hash-set! handle-semaphores handle (make-semaphore 0)) (hash-set! handle-results handle #f) (let* ((r (ww-cmd cmd)) @@ -514,20 +669,21 @@ ) ) ) + |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Web Wire Commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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)) - win-ids)) - (let ((r (ww-cmd 'quit))) - (car r))) + ; (define (ww-stop) + ; (ww-debug "ww-stop called") + ; (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))) ;; Global stylesheet (define (ww-set-stylesheet st) @@ -545,7 +701,7 @@ (define (ww-get-stylesheet) (let ((cmd (format "get-stylesheet"))) (let ((r (ww-cmd cmd))) - (displayln r) + (cmdr-dbg r) #t))) ;; Debug window @@ -562,24 +718,19 @@ (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)))) + (let ((ok (cmdr-ok r)) + (win-id (cmdr-win r))) + win-id))) ;; Close window (define (ww-close win-id) (let ((r (ww-cmd (format "close ~a" win-id)))) - (car r))) + r)) ;; Move window (define (ww-move win-id x y) (let ((r (ww-cmd (format "move ~a ~a ~a" win-id x y)))) - (car r))) + r)) ;; Resize window (define (ww-resize win-id width height) @@ -589,7 +740,7 @@ ;; 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))) + r)) ;; Set icon of window @@ -599,7 +750,7 @@ (cmd (format "set-icon ~a ~a" win-id (as-string (format "~a" icon-file)))) (r (ww-cmd cmd))) - (car r)) + r) (error "ww-set-icon - file does not exist"))) ;; Set menu of window @@ -726,70 +877,71 @@ (car r))))) ) + (define (new-handle) + #t) ;; set url (define (ww-set-url win-id url) - (let ((cmd (format "set-url ~a ~a ~a" - win-id (new-handle) (as-string url)))) + (let ((cmd (format "set-url ~a ~a" + win-id (as-string url)))) (ww-cmd cmd))) ;; 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) + (let ((cmd (format "set-html ~a ~a" + win-id (as-string (to-server-file html-file))))) (let ((r (ww-cmd cmd))) - (car r))) + 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 + (let* ((cmd (format "set-inner-html ~a ~a ~a" + win-id (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 + (ww-cmd cmd)) + (let* ((cmd (format "set-inner-html ~a ~a ~a" + win-id (format "~a" element-id) (as-string (format "~a" html-or-file)))) ) - (ww-await js-handle cmd)) + (ww-cmd 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))) + (let* ((cmd (format "get-inner-html ~a ~a" + win-id (format "~a" element-id))) ) - (ww-await js-handle cmd))) + (ww-cmd 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 ~a" win-id js-handle - (as-string element-id) (as-string attr) (as-string val)))) - (displayln cmd) + (let* ((cmd (format "set-attr ~a ~a ~a ~a" win-id + (as-string element-id) + (as-string attr) (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 ~a" win-id js-handle + (let* ((cmd (format "get-attr ~a ~a ~a" win-id (as-string element-id) (as-string attr)))) - (ww-await js-handle cmd))) - + (ww-cmd cmd))) ;; Get all attributes of an element with given id (define (mk-attrs _attrs) + (let* ((r (cmdr-r _attrs)) + (rr (hash-ref 'result + (with-input-from-string + (string-replace r "\\\"" "\"") + read-json)))) (let* ((attrs (make-hash))) (for-each (λ (attr-val) (hash-set! attrs @@ -797,13 +949,12 @@ (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 + (let* ((cmd (format "get-attrs ~a ~a" win-id (as-string element-id)))) - (mk-attrs (ww-await js-handle cmd)))) + (mk-attrs (ww-cmd cmd)))) ;; Get info of all elements for a selector (define (ww-get-elements win-id selector) @@ -814,7 +965,7 @@ (cons (string->symbol (car item)) (mk-attrs (cadr item))) ) - (ww-await js-handle cmd)))) + (ww-cmd cmd)))) ;; Delete attribute of element (define (ww-del-attr win-id element-id attr) @@ -847,6 +998,7 @@ (let* ((js-handle (new-handle)) (cmd (format "bind ~a ~a ~a ~a" win-id js-handle (as-string event) (as-string selector)))) + (ww-debug cmd) (map (lambda (info) (map string->symbol info)) (ww-await js-handle cmd)))) diff --git a/private/webui-wire-ffi.rkt b/private/webui-wire-ffi.rkt new file mode 100644 index 0000000..657066c --- /dev/null +++ b/private/webui-wire-ffi.rkt @@ -0,0 +1,183 @@ +#lang racket/base + +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/atomic + setup/dirs + "../utils/utils.rkt" + (prefix-in g: racket/gui) + ) + +(provide webwire-new + webwire-current + webwire-destroy + webwire-command + webwire-items + webwire-get + webwire-status + webwire-status->string + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Handle finalization +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define webwire-will (make-will-executor)) +(void (thread (λ () (let loop () (will-execute webwire-will) (loop))))) + + +(define-ffi-definer define-libwebui-wire + (ffi-lib "c:/devel/racket/webui-wire/build/Debug/libwebui-wire.dll" + #:custodian (current-custodian))) + ;(ffi-lib "libwebui-wire" '("3" "4" "5" #f) + ; #:get-lib-dirs (lambda () + ; (cons (build-path ".") (get-lib-search-dirs))) + ; #:fail (lambda () + ; (ffi-lib (get-lib-path "libwebui-wire.dll"))) + ; )) + +(define-cpointer-type _webui-handle #:tag 'webui-handle) +;(define _webui-handle _pointer) + +(define _webui-get-result + (_enum '(null = 0 + event + log + invalid-handle = 256 + ))) + +(define _webui-handle-status + (_enum '(valid = 1 + handle-destroyed + handle-needs-destroying + null-handle + existing-handle-destroy-this-one + handle-invalid-unexpected + ))) + +(define-libwebui-wire webwire-new + (_fun -> (handle : _webui-handle/null) + -> (begin + (unless (eq? handle #f) + (will-register webwire-will + handle (λ (handle) + (webwire-destroy handle)))) + handle)) + #:c-id webwire_new) + +(define-libwebui-wire webwire-current + (_fun -> (handle : _webui-handle/null) + -> (begin + (unless (eq? handle #f) + (will-register webwire-will + handle (λ (handle) + (webwire-destroy handle)))) + handle)) + #:c-id webwire_current) + +(define-libwebui-wire webwire-destroy + (_fun _webui-handle/null -> _void) + #:c-id webwire_destroy) + +(define-libwebui-wire webwire-command + (_fun _webui-handle/null _string/utf-8 + -> [r : _string/utf-8] + -> r + ) + #:c-id webwire_command) + +(define-libwebui-wire webwire-items + (_fun _webui-handle/null -> _uint) + #:c-id webwire_items) + +(define-libwebui-wire webwire-get + (_fun _webui-handle/null + [evt : (_ptr o _string/utf-8)] + [kind : (_ptr o _string/utf-8)] + [msg : (_ptr o _string/utf-8)] + -> [ result : _webui-get-result ] + -> (list result + evt + kind + msg) + ) + #:c-id webwire_get) + +#| + (if (eq? evt #f) + #f + (cast evt _pointer _string/utf-8)) + (if (eq? kind #f) + #f + (string->symbol + (cast kind _pointer _string/utf-8))) + (if (eq? msg #f) + #f + (cast msg _pointer _string/utf-8)) + ) +|# + +(define-libwebui-wire webwire-status + (_fun _webui-handle/null -> _webui-handle-status) + #:c-id webwire_status + ) + +(define-libwebui-wire webwire-status->string + (_fun _webui-handle-status + -> (r : _string/utf-8) + -> r) + #:c-id webwire_status_string) + + + + + + +;(define (webwire-new evt-cb log-cb) +; (parameterize ([g:current-eventspace (g:current-eventspace)]) +; (let ((evtcb (lambda (msg) +; (g:queue-callback (lambda () (evt-cb msg))))) +; (logcb (lambda (k m) +; (g:queue-callback (lambda () (log-cb k m))))) +; ) +; (webwire_new evtcb logcb)))) + +(define last-evt #f) + +(define (evt msg) + (displayln msg) + (set! last-evt msg)) + +(define last-log #f) + +(define (log k m) + (let ((msg (format "~a ~a" k m))) + (displayln msg) + (set! last-log msg))) + +(define (reader h) + (let ((l (webwire-get h))) + (let ((result (car l))) + (unless (or (eq? result 'null) (eq? result 'invalid-handle)) + (let* ((evt (cadr l)) + (kind (caddr l)) + (msg (cadddr l))) + (unless (eq? evt #f) + (displayln (format "EVENT:~a" evt))) + (unless (eq? kind #f) + (displayln (format "~a:~a" kind msg))) + (reader h))) + result))) + +(define (reader-thread h) + (thread (lambda () + (letrec ((f (lambda () + (let ((r (reader h))) + (sleep 0.01); + ;(displayln r) + (if (eq? r 'invalid-handle) + r + (f)))))) + (f))))) + diff --git a/utils/sprintf.rkt b/utils/sprintf.rkt new file mode 100644 index 0000000..fbc3337 --- /dev/null +++ b/utils/sprintf.rkt @@ -0,0 +1,114 @@ +(module sprintf racket/base + + (require racket/format + racket/string + ) + + (provide sprintf + sprintf* + ) + + (define re-format + #px"([^%]*)[%]([0-]{0,1})([1-9][0-9]*|[*]){0,1}([.]([0-9]+|[*])){0,1}(l*)([%dfsx])") + + (define-syntax shift + (syntax-rules () + ((_ args) + (let ((first (car args))) + (set! args (cdr args)) + first)))) + + (define (format-part zeros adjust-width precision kind arg) + (if (number? arg) + (let* ((pad-str (if (eq? zeros #f) " " + (if (string=? zeros "0") + "0" + " "))) + (adjust (if (eq? zeros #f) 'right + (if (string=? zeros "-") 'left 'right))) + (min-width (if (eq? adjust-width #f) 1 adjust-width)) + (precision (if (eq? precision #f) 0 + (if (eq? kind 'd) + 0 + precision))) + (base (if (eq? kind 'x) 16 10)) + ) + (when (eq? kind 's) + (error "argument is a number, but string expected")) + (let ((r (~r arg #:pad-string pad-str #:min-width min-width #:precision precision #:base base))) + (if (eq? adjust 'left) + (let ((r-trim (string-trim r))) + (string-append r-trim + (make-string + (- (string-length r) (string-length r-trim)) + #\space))) + r))) + (let* ((pad-str (if (string=? zeros "") " " zeros)) + (min-width (if (eq? adjust-width #f) 0 adjust-width)) + (max-width (if (eq? precision #f) +inf.0 precision)) + (adjust (if (eq? zeros #f) 'left + (if (string=? zeros "-") 'left 'right))) + ) + (unless (eq? kind 's) + (error "argument is a string, but a number is expected")) + (~a arg #:pad-string pad-str #:min-width min-width #:max-width max-width #:align adjust)) + ) + ) + + (define-syntax fmt + (syntax-rules () + ((_ a ...) + (format a ...)))) + + (define (do-format format args) + (if (null? args) + (let ((m (regexp-match re-format format))) + (unless (eq? m #f) + (error (fmt "formatting left, but no arguments left: ~a" format))) + format) + (let ((m (regexp-match re-format format))) + (when (eq? m #f) + (error (fmt "arguments left, but no formatting left: ~a" format))) + (let* ((matched-length (string-length (list-ref m 0))) + (prefix (list-ref m 1)) + (zeros (list-ref m 2)) + (adjust-width (list-ref m 3)) + (precision (list-ref m 5)) + (long (list-ref m 6)) + (kind (string->symbol (list-ref m 7))) + ) + (unless (eq? adjust-width #f) + (set! adjust-width (if (string=? adjust-width "*") + (let ((n (shift args))) + (when (null? args) + (error "* requires >= 2 arguments left")) + (unless (number? n) + (error "* requires a number?")) + n) + (string->number adjust-width)))) + (unless (eq? precision #f) + (set! precision (if (string=? precision "*") + (let ((n (shift args))) + (when (null? args) + (error "* requires >= 2 arguments left")) + (unless (number? n) + (error "* requires a number?")) + n) + (string->number precision)))) + (string-append prefix + (if (eq? kind '%) + "%" + (format-part zeros adjust-width precision kind (shift args))) + (do-format (substring format matched-length) args)))) + ) + ) + + + (define (sprintf format . args) + (do-format format args)) + + (define (sprintf* format args) + (do-format format args)) + + + ) ; end of module \ No newline at end of file