136 lines
4.3 KiB
Racket
136 lines
4.3 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
racket/draw/lock
|
|
"../common/queue.rkt"
|
|
"../common/freeze.rkt"
|
|
"const.rkt")
|
|
|
|
(provide gtk-start-event-pump
|
|
|
|
set-widget-hook!
|
|
|
|
;; from common/queue:
|
|
current-eventspace
|
|
queue-event
|
|
yield)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Gtk event pump
|
|
|
|
(define-gtk gtk_init (_fun _int _pointer -> _void))
|
|
(gtk_init 0 #f)
|
|
|
|
(define-gtk gtk_events_pending (_fun -> _gboolean))
|
|
(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean))
|
|
|
|
(define _GMainContext (_cpointer 'GMainContext))
|
|
(define _GdkEvent (_cpointer 'GdkEvent))
|
|
|
|
(define-cstruct _GPollFD ([fd _int]
|
|
[events _short]
|
|
[revents _short]))
|
|
|
|
(define-glib g_main_context_default (_fun -> _GMainContext))
|
|
(define-glib g_main_context_query (_fun _GMainContext
|
|
_int
|
|
_pointer
|
|
_pointer ;; GPollFD array
|
|
_int
|
|
-> _int))
|
|
|
|
(define-gdk gdk_event_handler_set (_fun (_fun _GdkEvent _pointer -> _void)
|
|
_pointer
|
|
(_fun _pointer -> _void)
|
|
-> _void))
|
|
(define-gdk gdk_event_copy (_fun _GdkEvent -> _GdkEvent))
|
|
(define-gdk gdk_event_free (_fun _GdkEvent -> _void))
|
|
(define-gtk gtk_main_do_event (_fun _GdkEvent -> _void))
|
|
(define-gtk gtk_get_event_widget (_fun _GdkEvent -> (_or-null _GtkWidget)))
|
|
|
|
(define poll-fd-count 1)
|
|
(define poll-fds (make-GPollFD 0 0 0))
|
|
(define timeout (malloc _int))
|
|
|
|
;; These are OS-specific, but they tend to be the same across OSes:
|
|
(define POLLIN #x1)
|
|
(define POLLOUT #x4)
|
|
(define POLLERR #x8)
|
|
(define POLLHUP #x10)
|
|
|
|
(define-mz scheme_get_fdset (_fun _pointer _int -> _pointer))
|
|
(define-mz scheme_fdset (_fun _pointer _int -> _void))
|
|
(define-mz scheme_set_wakeup_time (_fun _pointer _double -> _void))
|
|
|
|
(define (install-wakeup fds)
|
|
(pre-event-sync #t)
|
|
(let ([n (g_main_context_query (g_main_context_default)
|
|
#x7FFFFFFF ; max-int, hopefully
|
|
timeout
|
|
poll-fds
|
|
poll-fd-count)])
|
|
(let ([to (ptr-ref timeout _int)])
|
|
(when (to . >= . 0)
|
|
(scheme_set_wakeup_time fds (+ (current-inexact-milliseconds) to))))
|
|
(if (n . > . poll-fd-count)
|
|
(begin
|
|
(set! poll-fds (malloc _GPollFD n))
|
|
(set! poll-fd-count n)
|
|
(install-wakeup fds))
|
|
(for ([i (in-range n)])
|
|
(let* ([gfd (ptr-ref poll-fds _GPollFD i)]
|
|
[fd (GPollFD-fd gfd)]
|
|
[events (GPollFD-events gfd)])
|
|
(when (not (zero? (bitwise-and events POLLIN)))
|
|
(scheme_fdset (scheme_get_fdset fds 0) fd))
|
|
(when (not (zero? (bitwise-and events POLLOUT)))
|
|
(scheme_fdset (scheme_get_fdset fds 1) fd))
|
|
(when (not (zero? (bitwise-and events (bitwise-ior POLLERR POLLHUP))))
|
|
(scheme_fdset (scheme_get_fdset fds 2) fd)))))))
|
|
|
|
(set-check-queue! gtk_events_pending)
|
|
(set-queue-wakeup! install-wakeup)
|
|
|
|
(define widget-hook (lambda (gtk) #f))
|
|
(define (set-widget-hook! proc) (set! widget-hook proc))
|
|
|
|
(define (event-dispatch evt ignored)
|
|
(let* ([gtk (gtk_get_event_widget evt)]
|
|
[wx (and gtk (widget-hook gtk))])
|
|
(cond
|
|
[(and (= (ptr-ref evt _int) GDK_EXPOSE)
|
|
wx
|
|
(send wx direct-update?))
|
|
(gtk_main_do_event evt)]
|
|
[(and wx (send wx get-eventspace))
|
|
=> (lambda (e)
|
|
(let ([evt (gdk_event_copy evt)])
|
|
(queue-event e (lambda ()
|
|
(call-as-unfreeze-point
|
|
(lambda ()
|
|
(gtk_main_do_event evt)
|
|
(gdk_event_free evt)))))))]
|
|
[else
|
|
(gtk_main_do_event evt)])))
|
|
(define (uninstall ignored)
|
|
(printf "uninstalled!?\n"))
|
|
|
|
(gdk_event_handler_set event-dispatch
|
|
#f
|
|
uninstall)
|
|
|
|
(define (dispatch-all-ready)
|
|
(pre-event-sync #f)
|
|
(when (gtk_events_pending)
|
|
(gtk_main_iteration_do #f)
|
|
(dispatch-all-ready)))
|
|
|
|
(define (gtk-start-event-pump)
|
|
(thread (lambda ()
|
|
(let loop ()
|
|
(sync queue-evt)
|
|
(as-entry dispatch-all-ready)
|
|
(loop)))))
|