Refactoring to webui FFI.

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)))))
+