84 lines
2.5 KiB
Racket
84 lines
2.5 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/class
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/queue.rkt"
|
|
"queue.rkt"
|
|
"utils.rkt"
|
|
"types.rkt")
|
|
|
|
(provide
|
|
(protect-out widget%
|
|
gtk->wx
|
|
|
|
gtk_widget_show
|
|
gtk_widget_hide
|
|
gtk_widget_destroy
|
|
|
|
gtk_vbox_new
|
|
gtk_hbox_new
|
|
gtk_box_pack_start
|
|
gtk_box_pack_end))
|
|
|
|
(define-gtk gtk_widget_show (_fun _GtkWidget -> _void))
|
|
(define-gtk gtk_widget_hide (_fun _GtkWidget -> _void))
|
|
|
|
(define-gtk gtk_widget_destroy (_fun _pointer -> _void))
|
|
|
|
(define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget))
|
|
(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget))
|
|
(define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void))
|
|
(define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void))
|
|
(define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget)))
|
|
|
|
(define-signal-handler connect-destroy "destroy"
|
|
(_fun _GtkWidget _pointer -> _void)
|
|
(lambda (gtk cell)
|
|
(free-immobile-cell cell)))
|
|
|
|
(define widget%
|
|
(class object%
|
|
(init gtk
|
|
[extra-gtks null]
|
|
[parent #f])
|
|
(init-field [eventspace (if parent
|
|
(send parent get-eventspace)
|
|
(current-eventspace))])
|
|
|
|
(when (eventspace-shutdown? eventspace)
|
|
(error '|GUI object initialization| "the eventspace has been shutdown"))
|
|
|
|
(define/public (get-eventspace) eventspace)
|
|
(define/public (direct-update?) #t)
|
|
|
|
(define/public (install-widget-parent p)
|
|
(set! eventspace (send p get-eventspace)))
|
|
|
|
(super-new)
|
|
|
|
(define/public (register-extra-gtk gtk extra-gtk)
|
|
(define cell (g_object_get_data gtk "wx"))
|
|
(g_object_set_data extra-gtk "wx" cell))
|
|
|
|
(atomically
|
|
(let ([cell (malloc-immobile-cell (make-weak-box this))])
|
|
(g_object_set_data gtk "wx" cell)
|
|
(for ([gtk (in-list extra-gtks)])
|
|
(g_object_set_data gtk "wx" cell))
|
|
(connect-destroy gtk cell)))))
|
|
|
|
(define (gtk->wx gtk)
|
|
(let ([ptr (g_object_get_data gtk "wx")])
|
|
(and ptr
|
|
(let ([wb (ptr-ref ptr _scheme)])
|
|
(and wb (weak-box-value wb))))))
|
|
|
|
(set-widget-hook! (lambda (gtk)
|
|
(let loop ([gtk gtk])
|
|
(and gtk
|
|
(let ([wx (gtk->wx gtk)])
|
|
(or wx
|
|
(loop (gtk_widget_get_parent gtk))))))))
|
|
|