184 lines
4.9 KiB
Racket
184 lines
4.9 KiB
Racket
#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)))))
|
|
|