gtk combo boxes
This commit is contained in:
Matthew Flatt
parent
626ceef11b
commit
37d4cfb148
|
|
@ -110,15 +110,20 @@
|
|||
[get-menu (lambda () menu)]
|
||||
[append (lambda (item)
|
||||
(check-label-string '(method combo-field% append) item)
|
||||
(make-object menu-item% item menu
|
||||
(lambda (i e)
|
||||
(focus)
|
||||
(set-value item)
|
||||
(let ([e (get-editor)])
|
||||
(send e set-position 0 (send e last-position)))
|
||||
(send (as-entry (lambda () (mred->wx this)))
|
||||
command
|
||||
(make-object wx:control-event% 'text-field)))))])
|
||||
(unless (send (mred->wx this) append-combo-item item
|
||||
(lambda () (handle-selected item)))
|
||||
(make-object menu-item% item menu
|
||||
(lambda (i e)
|
||||
(handle-selected item)))))])
|
||||
(private
|
||||
[handle-selected (lambda (item)
|
||||
(focus)
|
||||
(set-value item)
|
||||
(let ([e (get-editor)])
|
||||
(send e set-position 0 (send e last-position)))
|
||||
(send (as-entry (lambda () (mred->wx this)))
|
||||
command
|
||||
(make-object wx:control-event% 'text-field)))])
|
||||
(override
|
||||
[on-subwindow-event (lambda (w e)
|
||||
(and (send e button-down?)
|
||||
|
|
@ -130,7 +135,6 @@
|
|||
(private-field
|
||||
[menu (new popup-menu% [font font])])
|
||||
(sequence
|
||||
(for-each (lambda (item)
|
||||
(append item))
|
||||
choices)
|
||||
(super-init label parent callback init-value (list* combo-flag 'single style))))))
|
||||
(super-init label parent callback init-value (list* combo-flag 'single style))
|
||||
(for-each (lambda (item) (append item))
|
||||
choices)))))
|
||||
|
|
|
|||
|
|
@ -330,6 +330,9 @@
|
|||
(scroller-page scroller)
|
||||
1)]))
|
||||
|
||||
(define/public (append-combo-item str) #f)
|
||||
(define/public (on-combo-select i) (void))
|
||||
|
||||
(define bg-col (make-object color% "white"))
|
||||
(define/public (get-canvas-background) (if (memq 'transparent canvas-style)
|
||||
#f
|
||||
|
|
|
|||
|
|
@ -20,6 +20,9 @@
|
|||
|
||||
(define-gtk gtk_drawing_area_new (_fun -> _GtkWidget))
|
||||
|
||||
(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget))
|
||||
(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void))
|
||||
|
||||
(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))
|
||||
|
||||
(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget))
|
||||
|
|
@ -37,6 +40,12 @@
|
|||
(define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*))
|
||||
(define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void))
|
||||
|
||||
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
|
||||
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
|
||||
|
||||
(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void)
|
||||
#:c-id g_object_set)
|
||||
|
||||
(define-cstruct _GdkColor ([pixel _uint32]
|
||||
[red _uint16]
|
||||
[green _uint16]
|
||||
|
|
@ -49,9 +58,30 @@
|
|||
(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void))
|
||||
(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void))
|
||||
|
||||
;; We rely some on the implementation of GtkComboBoxEntry to replace
|
||||
;; the drawing routine.
|
||||
(define-cstruct _GList ([data _pointer]))
|
||||
(define-gdk gdk_window_get_children (_fun _pointer -> _GList-pointer/null))
|
||||
(define-gdk gdk_window_hide (_fun _pointer -> _void))
|
||||
(define (get-subwindow gtk)
|
||||
(let* ([win (g_object_get_window gtk)]
|
||||
[subs (gdk_window_get_children win)])
|
||||
(if subs
|
||||
(GList-data subs)
|
||||
win)))
|
||||
|
||||
(define-signal-handler connect-changed "changed"
|
||||
(_fun _GtkWidget -> _void)
|
||||
(lambda (gtk)
|
||||
(let ([wx (gtk->wx gtk)])
|
||||
(send wx combo-maybe-clicked))))
|
||||
|
||||
(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
|
||||
(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
|
||||
|
||||
(define (handle-expose gtk event)
|
||||
(let ([wx (gtk->wx gtk)])
|
||||
(let ([gc (send wx get-canvas-background-for-clearing)])
|
||||
(let ([gc (send wx get-canvas-background-for-clearing)])
|
||||
(when gc
|
||||
(gdk_draw_rectangle (g_object_get_window gtk) gc #t
|
||||
0 0 32000 32000)))
|
||||
|
|
@ -74,6 +104,7 @@
|
|||
(define handle_value_changed_v
|
||||
(function-ptr handle-value-changed-v (_fun #:atomic? #t _GtkWidget _pointer -> _void)))
|
||||
|
||||
(define-gtk gtk_entry_get_type (_fun -> _GType))
|
||||
|
||||
(define canvas%
|
||||
(class (client-size-mixin window%)
|
||||
|
|
@ -86,36 +117,45 @@
|
|||
(inherit get-gtk set-size get-size get-client-size
|
||||
on-size register-as-child get-top-win)
|
||||
|
||||
(define client-gtk (gtk_drawing_area_new))
|
||||
(define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box)
|
||||
(if (or (memq 'hscroll style)
|
||||
(memq 'vscroll style))
|
||||
(let ([hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
|
||||
[vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)])
|
||||
(let ([h (gtk_hbox_new #f 0)]
|
||||
[v (gtk_vbox_new #f 0)]
|
||||
[v2 (gtk_vbox_new #f 0)]
|
||||
[h2 (gtk_vbox_new #f 0)]
|
||||
[hscroll (gtk_hscrollbar_new hadj)]
|
||||
[vscroll (gtk_vscrollbar_new vadj)]
|
||||
[resize-box (gtk_drawing_area_new)])
|
||||
(gtk_box_pack_start h v #t #t 0)
|
||||
(gtk_box_pack_start v client-gtk #t #t 0)
|
||||
(gtk_box_pack_start h v2 #f #f 0)
|
||||
(gtk_box_pack_start v2 vscroll #t #t 0)
|
||||
(gtk_box_pack_start v h2 #f #f 0)
|
||||
(gtk_box_pack_start h2 hscroll #t #t 0)
|
||||
(gtk_box_pack_start v2 resize-box #f #f 0)
|
||||
(gtk_widget_show hscroll)
|
||||
(gtk_widget_show vscroll)
|
||||
(gtk_widget_show h)
|
||||
(gtk_widget_show v)
|
||||
(gtk_widget_show v2)
|
||||
(gtk_widget_show h2)
|
||||
(gtk_widget_show resize-box)
|
||||
(gtk_widget_show client-gtk)
|
||||
(values h hadj vadj h2 v2 resize-box)))
|
||||
(values client-gtk #f #f #f #f #f)))
|
||||
(define is-combo? (memq 'combo style))
|
||||
|
||||
(define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box)
|
||||
(cond
|
||||
[(or (memq 'hscroll style)
|
||||
(memq 'vscroll style))
|
||||
(let* ([client-gtk (gtk_drawing_area_new)]
|
||||
[hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
|
||||
[vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)])
|
||||
(let ([h (gtk_hbox_new #f 0)]
|
||||
[v (gtk_vbox_new #f 0)]
|
||||
[v2 (gtk_vbox_new #f 0)]
|
||||
[h2 (gtk_vbox_new #f 0)]
|
||||
[hscroll (gtk_hscrollbar_new hadj)]
|
||||
[vscroll (gtk_vscrollbar_new vadj)]
|
||||
[resize-box (gtk_drawing_area_new)])
|
||||
(gtk_box_pack_start h v #t #t 0)
|
||||
(gtk_box_pack_start v client-gtk #t #t 0)
|
||||
(gtk_box_pack_start h v2 #f #f 0)
|
||||
(gtk_box_pack_start v2 vscroll #t #t 0)
|
||||
(gtk_box_pack_start v h2 #f #f 0)
|
||||
(gtk_box_pack_start h2 hscroll #t #t 0)
|
||||
(gtk_box_pack_start v2 resize-box #f #f 0)
|
||||
(gtk_widget_show hscroll)
|
||||
(gtk_widget_show vscroll)
|
||||
(gtk_widget_show h)
|
||||
(gtk_widget_show v)
|
||||
(gtk_widget_show v2)
|
||||
(gtk_widget_show h2)
|
||||
(gtk_widget_show resize-box)
|
||||
(gtk_widget_show client-gtk)
|
||||
(values client-gtk h hadj vadj h2 v2 resize-box)))]
|
||||
[is-combo?
|
||||
(let* ([gtk (gtk_combo_box_entry_new_text)]
|
||||
[orig-entry (gtk_bin_get_child gtk)])
|
||||
(values orig-entry gtk #f #f #f #f #f))]
|
||||
[else
|
||||
(let ([client-gtk (gtk_drawing_area_new)])
|
||||
(values client-gtk client-gtk #f #f #f #f #f))]))
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk gtk]
|
||||
|
|
@ -123,7 +163,9 @@
|
|||
[no-show? (memq 'deleted style)]
|
||||
[extra-gtks (if (eq? client-gtk gtk)
|
||||
null
|
||||
(list client-gtk hscroll-adj vscroll-adj))])
|
||||
(if hscroll-adj
|
||||
(list client-gtk hscroll-adj vscroll-adj)
|
||||
(list client-gtk)))])
|
||||
|
||||
(set-size x y w h)
|
||||
|
||||
|
|
@ -134,7 +176,11 @@
|
|||
[h (box 0)])
|
||||
(get-client-size w h)
|
||||
(values (unbox w) (unbox h))))]
|
||||
[window-lock (send (get-top-win) get-dc-lock)]))
|
||||
[window-lock (send (get-top-win) get-dc-lock)]
|
||||
[get-window (lambda (client-gtk)
|
||||
(if is-combo?
|
||||
(get-subwindow client-gtk)
|
||||
(g_object_get_window client-gtk)))]))
|
||||
|
||||
(gtk_widget_realize gtk)
|
||||
(gtk_widget_realize client-gtk)
|
||||
|
|
@ -146,7 +192,7 @@
|
|||
(GtkRequisition-height r)
|
||||
(GtkRequisition-height r))))
|
||||
|
||||
(g_signal_connect client-gtk "expose_event" handle_expose)
|
||||
(g_signal_connect client-gtk "expose-event" handle_expose)
|
||||
(connect-key-and-mouse client-gtk)
|
||||
(connect-focus client-gtk)
|
||||
(gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK
|
||||
|
|
@ -294,6 +340,19 @@
|
|||
gc)
|
||||
#f)))
|
||||
|
||||
(when is-combo?
|
||||
(connect-changed client-gtk))
|
||||
|
||||
(define/public (append-combo-item str)
|
||||
(gtk_combo_box_append_text gtk str))
|
||||
|
||||
(define/public (combo-maybe-clicked)
|
||||
(let ([i (gtk_combo_box_get_active gtk)])
|
||||
(when (i . > . -1)
|
||||
(gtk_combo_box_set_active gtk -1)
|
||||
(queue-window-event this (lambda () (on-combo-select i))))))
|
||||
(define/public (on-combo-select i) (void))
|
||||
|
||||
(def/public-unimplemented set-background-to-gray)
|
||||
|
||||
(define/public (do-scroll direction)
|
||||
|
|
|
|||
|
|
@ -21,14 +21,15 @@
|
|||
(class default-dc-backend%
|
||||
(init-field gtk
|
||||
get-client-size
|
||||
window-lock)
|
||||
window-lock
|
||||
[get-window g_object_get_window])
|
||||
(inherit reset-cr)
|
||||
|
||||
(define c #f)
|
||||
|
||||
(define/override (get-cr)
|
||||
(or c
|
||||
(let ([w (g_object_get_window gtk)])
|
||||
(let ([w (get-window gtk)])
|
||||
(and w
|
||||
(begin
|
||||
;; Under Windows, creating a Cairo context within
|
||||
|
|
@ -36,7 +37,7 @@
|
|||
;; within the same frame. So we use a lock to
|
||||
;; serialize drawing to different contexts.
|
||||
(when window-lock (semaphore-wait window-lock))
|
||||
(set! c (gdk_cairo_create w))
|
||||
(set! c (gdk_cairo_create w))
|
||||
(reset-cr c)
|
||||
c)))))
|
||||
|
||||
|
|
|
|||
148
collects/mred/private/wx/gtk/subtype.rkt
Normal file
148
collects/mred/private/wx/gtk/subtype.rkt
Normal file
|
|
@ -0,0 +1,148 @@
|
|||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/alloc
|
||||
"utils.rkt"
|
||||
"const.rkt"
|
||||
"types.rkt")
|
||||
|
||||
(provide make-subclass
|
||||
GtkWidgetClass-expose_event
|
||||
set-GtkWidgetClass-expose_event!)
|
||||
|
||||
(define _GTypeClass _GType)
|
||||
|
||||
(define-cstruct _GObjectClass ([g_type_class _GTypeClass]
|
||||
[construct_properties _pointer]
|
||||
[constructor _fpointer]
|
||||
[set_property _fpointer]
|
||||
[get_property _fpointer]
|
||||
[dispose _fpointer]
|
||||
[finalize _fpointer]
|
||||
[dispatch_properties _fpointer]
|
||||
[notify _fpointer]
|
||||
[constructed _fpointer]
|
||||
[pdummy1 _pointer]
|
||||
[pdummy2 _pointer]
|
||||
[pdummy3 _pointer]
|
||||
[pdummy4 _pointer]
|
||||
[pdummy5 _pointer]
|
||||
[pdummy6 _pointer]
|
||||
[pdummy7 _pointer]))
|
||||
|
||||
(define-cstruct _GtkObjectClass ([parent_class _GObjectClass]
|
||||
[set_arg _fpointer]
|
||||
[get_arg _fpointer]
|
||||
[destroy _fpointer]))
|
||||
|
||||
(define-cstruct _GtkWidgetClass ([parent_class _GtkObjectClass]
|
||||
[activate_signal _uint]
|
||||
[set_scroll_adjustments_signal _uint]
|
||||
[dispatch_child_properties_changed _fpointer]
|
||||
[show _fpointer]
|
||||
[show_all _fpointer]
|
||||
[hide _fpointer]
|
||||
[hide_all _fpointer]
|
||||
[map _fpointer]
|
||||
[unmap _fpointer]
|
||||
[realize _fpointer]
|
||||
[unrealize _fpointer]
|
||||
[size_request _fpointer]
|
||||
[size_allocate _fpointer]
|
||||
[parent_set _fpointer]
|
||||
[hierarchy_changed _fpointer]
|
||||
[style_set _fpointer]
|
||||
[direction_changed _fpointer]
|
||||
[grab_notify _fpointer]
|
||||
[child_notify _fpointer]
|
||||
[mnemonic_activate _fpointer]
|
||||
[grab_focus _fpointer]
|
||||
[focus _fpointer]
|
||||
[event _fpointer]
|
||||
[button_press_event _fpointer]
|
||||
[button_release_event _fpointer]
|
||||
[scroll_event _fpointer]
|
||||
[motion_notify_event _fpointer]
|
||||
[delete_event _fpointer]
|
||||
[destroy_event _fpointer]
|
||||
[whatever _pointer] ;;; HACK!!!!!! Something is wrong so that expose shows up in the wrong place
|
||||
[expose_event (_fun #:atomic? #t _GtkWidget _GdkEventExpose -> _void)]
|
||||
[key_press_event _fpointer]
|
||||
[key_release_event _fpointer]
|
||||
[enter_notify_event _fpointer]
|
||||
[leave_notify_event _fpointer]
|
||||
[configure_event _fpointer]
|
||||
[focus_in_event _fpointer]
|
||||
[focus_out_event _fpointer]
|
||||
[map_event _fpointer]
|
||||
[unmap_event _fpointer]
|
||||
[property_notify_event _fpointer]
|
||||
[selection_clear_event _fpointer]
|
||||
[selection_request_event _fpointer]
|
||||
[selection_notify_event _fpointer]
|
||||
[proximity_in_event _fpointer]
|
||||
[proximity_out_event _fpointer]
|
||||
[visibility_notify_event _fpointer]
|
||||
[client_event _fpointer]
|
||||
[no_expose_event _fpointer]
|
||||
[window_state_event _fpointer]
|
||||
[selection_get _fpointer]
|
||||
[selection_received _fpointer]
|
||||
[drag_begin _fpointer]
|
||||
[drag_end _fpointer]
|
||||
[drag_data_get _fpointer]
|
||||
[drag_data_delete _fpointer]
|
||||
[drag_leave _fpointer]
|
||||
[drag_motion _fpointer]
|
||||
[drag_drop _fpointer]
|
||||
[drag_data_received _fpointer]
|
||||
[popup_menu _fpointer]
|
||||
[show_help _fpointer]
|
||||
[get_accessible _fpointer]
|
||||
[screen_changed _fpointer]
|
||||
[can_activate_accel _fpointer]
|
||||
[grab_broken_event _fpointer]
|
||||
[composited_changed _fpointer]
|
||||
[query_tooltip _fpointer]
|
||||
[gtk_reserved5 _fpointer]
|
||||
[gtk_reserved6 _fpointer]
|
||||
[gtk_reserved7 _fpointer]))
|
||||
|
||||
(define-cstruct _GTypeQuery ([type _GType]
|
||||
[type_name _string]
|
||||
[class_size _uint]
|
||||
[instance_size _uint]))
|
||||
|
||||
(define-gobj g_type_query (_fun _GType _GTypeQuery-pointer -> _void))
|
||||
|
||||
(define-cstruct _GTypeInfo ([class_size _uint16]
|
||||
[base_init _fpointer]
|
||||
[base_finalize _fpointer]
|
||||
[class_init (_fun #:atomic? #t _GtkWidgetClass-pointer _pointer -> _void)]
|
||||
[class_finalize _fpointer]
|
||||
[class_data _pointer]
|
||||
[instance_size _uint16]
|
||||
[n_preallocs _uint16]
|
||||
[instance_init _fpointer]
|
||||
[value_table _pointer]))
|
||||
|
||||
(define-gobj g_type_register_static (_fun _GType _string _GTypeInfo-pointer _int -> _GType))
|
||||
|
||||
(define saves null)
|
||||
|
||||
(define (make-subclass base-type name class-init-func)
|
||||
(when class-init-func
|
||||
(set! saves (cons class-init-func saves)))
|
||||
(let ([q (make-GTypeQuery 0 #f 0 0)])
|
||||
(g_type_query base-type q)
|
||||
(let ([ti (make-GTypeInfo (GTypeQuery-class_size q)
|
||||
#f
|
||||
#f
|
||||
class-init-func
|
||||
#f
|
||||
#f
|
||||
(GTypeQuery-instance_size q)
|
||||
0
|
||||
#f
|
||||
#f)])
|
||||
(g_type_register_static base-type name ti 0))))
|
||||
|
||||
|
|
@ -6,6 +6,7 @@
|
|||
_GtkWidget _GtkWindow
|
||||
_gpointer
|
||||
_GdkEventExpose
|
||||
_GType
|
||||
|
||||
_fnpointer
|
||||
_gboolean
|
||||
|
|
@ -20,6 +21,8 @@
|
|||
_GdkEventCrossing _GdkEventCrossing-pointer
|
||||
(struct-out GdkEventCrossing))
|
||||
|
||||
(define _GType _long)
|
||||
|
||||
(define _GdkWindow (_cpointer/null 'GdkWindow))
|
||||
|
||||
(define _GtkWidget (_cpointer 'GtkWidget))
|
||||
|
|
|
|||
|
|
@ -19,6 +19,8 @@
|
|||
g_object_get_data
|
||||
g_signal_connect
|
||||
|
||||
g_object_new
|
||||
|
||||
(rename-out [g_object_get g_object_get_window])
|
||||
|
||||
get-gtk-object-flags
|
||||
|
|
@ -87,6 +89,8 @@
|
|||
[w : (_ptr o _GdkWindow)]
|
||||
(_pointer = #f) -> _void -> w))
|
||||
|
||||
(define-gobj g_object_new (_fun _GType _pointer -> _GtkWidget))
|
||||
|
||||
;; This seems dangerous, since the shape of GtkObject is not
|
||||
;; documented. But it seems to be the only way to get and set
|
||||
;; flags.
|
||||
|
|
|
|||
|
|
@ -162,7 +162,11 @@
|
|||
(private-field
|
||||
[l (and label
|
||||
(make-object wx-message% #f proxy p label -1 -1 null font))]
|
||||
[c (make-object wx-text-editor-canvas% #f proxy this p
|
||||
[c (make-object (class wx-text-editor-canvas%
|
||||
(define/override (on-combo-select i)
|
||||
((list-ref callbacks (- (length callbacks) i 1))))
|
||||
(super-new))
|
||||
#f proxy this p
|
||||
(append
|
||||
'(control-border)
|
||||
(if (memq 'combo style)
|
||||
|
|
@ -172,7 +176,13 @@
|
|||
(if (memq 'hscroll style)
|
||||
null
|
||||
'(hide-hscroll))
|
||||
'(hide-vscroll hide-hscroll))))])
|
||||
'(hide-vscroll hide-hscroll))))]
|
||||
[callbacks null])
|
||||
(public
|
||||
[append-combo-item (lambda (s cb)
|
||||
(and (send c append-combo-item s)
|
||||
(set! callbacks (cons cb callbacks))
|
||||
#t))])
|
||||
(sequence
|
||||
(send c skip-subwindow-events? #t)
|
||||
(when l
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user