From 37d4cfb14863683e6501a1ba975a933aae3847ba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Jul 2010 13:04:39 -0600 Subject: [PATCH] gtk combo boxes --- collects/mred/private/mrtextfield.rkt | 30 +++-- collects/mred/private/wx/cocoa/canvas.rkt | 3 + collects/mred/private/wx/gtk/canvas.rkt | 127 ++++++++++++++----- collects/mred/private/wx/gtk/dc.rkt | 7 +- collects/mred/private/wx/gtk/subtype.rkt | 148 ++++++++++++++++++++++ collects/mred/private/wx/gtk/types.rkt | 3 + collects/mred/private/wx/gtk/utils.rkt | 4 + collects/mred/private/wxtextfield.rkt | 14 +- 8 files changed, 284 insertions(+), 52 deletions(-) create mode 100644 collects/mred/private/wx/gtk/subtype.rkt diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index e76c938ca1..400acb4629 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -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))))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index ccfed82f6e..644cb8bff6 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -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 diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 4ee321b124..ebed237152 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -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) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index a421218e31..bb31608e69 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -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))))) diff --git a/collects/mred/private/wx/gtk/subtype.rkt b/collects/mred/private/wx/gtk/subtype.rkt new file mode 100644 index 0000000000..33304459b0 --- /dev/null +++ b/collects/mred/private/wx/gtk/subtype.rkt @@ -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)))) + diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 49305bcf72..20d9797da4 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -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)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index d3c6946cef..a8e27d4a3e 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -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. diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index 629b070cda..7c92b5819c 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -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