finish pinning down gtk allocation
original commit: 43aeaacd7a598f834002b75b1ee72f4b7cd04b85
This commit is contained in:
Matthew Flatt
parent
1752204327
commit
a4305ae6a2
15
collects/mred/private/wx/cocoa/README.txt
Normal file
15
collects/mred/private/wx/cocoa/README.txt
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
|
||||
Allocation rules:
|
||||
|
||||
* Use `as-objc-allocation' when creating a Cocoa object. When the
|
||||
resulting reference becomes unreachable, the Cocoa object will be
|
||||
releaset.
|
||||
|
||||
* Use `with-autorelease' in atomic mode around calls that autorelease
|
||||
and where the release should take effect immediate. Do not create
|
||||
an autorelease pool except in atomic mode.
|
||||
|
||||
* Other autoreleased objects may end up in the root pool installed by
|
||||
"pool.rkt". The root pool is periodically destroyed and replaced;
|
||||
call `queue-autorelease-flush' if you need to encurage replacement
|
||||
of the pool.
|
||||
17
collects/mred/private/wx/gtk/README.txt
Normal file
17
collects/mred/private/wx/gtk/README.txt
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
Allocation rules:
|
||||
|
||||
* Use `as-gtk-allocation' when creating a Gtk widget that is the main
|
||||
container for a given window<%> object. When the resulting
|
||||
reference becomes unreachable, the widget will be released with
|
||||
gtk_widget_destroy() through a finalizer.
|
||||
|
||||
* Use `atomically' to create and attach a sub-widget within the main
|
||||
widget. Don't use gtk_widget_destroy(); the containing widget will
|
||||
destroy the enclosing widget.
|
||||
|
||||
* For temporary objects, use `atomically' to wrap both the allocation
|
||||
and release.
|
||||
|
||||
Every call to a function whose name contains "new" needs to be in one
|
||||
of those cases.
|
||||
|
|
@ -135,7 +135,8 @@
|
|||
(let ([gc (send wx get-canvas-background-for-clearing)])
|
||||
(when gc
|
||||
(gdk_draw_rectangle (widget-window gtk) gc #t
|
||||
0 0 32000 32000))))))
|
||||
0 0 32000 32000)
|
||||
(gdk_gc_unref gc))))))
|
||||
#t))
|
||||
|
||||
(define-signal-handler connect-expose-border "expose-event"
|
||||
|
|
@ -197,61 +198,62 @@
|
|||
(define-values (client-gtk gtk
|
||||
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
|
||||
combo-button-gtk)
|
||||
(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)])
|
||||
(when has-border?
|
||||
(gtk_container_set_border_width h margin))
|
||||
(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)
|
||||
(unless (memq 'hscroll style)
|
||||
(gtk_widget_hide hscroll)
|
||||
(gtk_widget_hide resize-box))
|
||||
(unless (memq 'vscroll style)
|
||||
(gtk_widget_hide v2))
|
||||
(values client-gtk h hadj vadj
|
||||
(and (memq 'hscroll style) h2)
|
||||
(and (memq 'vscroll style) v2)
|
||||
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
|
||||
#f)))]
|
||||
[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 (extract-combo-button gtk)))]
|
||||
[has-border?
|
||||
(let ([client-gtk (gtk_drawing_area_new)]
|
||||
[h (gtk_hbox_new #f 0)])
|
||||
(gtk_box_pack_start h client-gtk #t #t 0)
|
||||
(gtk_container_set_border_width h margin)
|
||||
(connect-expose-border h)
|
||||
(gtk_widget_show client-gtk)
|
||||
(values client-gtk h #f #f #f #f #f #f))]
|
||||
[else
|
||||
(let ([client-gtk (gtk_drawing_area_new)])
|
||||
(values client-gtk client-gtk #f #f #f #f #f #f))]))
|
||||
(atomically ;; need to connect all children to gtk to avoid leaks
|
||||
(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 (as-gtk-allocation (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)])
|
||||
(when has-border?
|
||||
(gtk_container_set_border_width h margin))
|
||||
(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)
|
||||
(unless (memq 'hscroll style)
|
||||
(gtk_widget_hide hscroll)
|
||||
(gtk_widget_hide resize-box))
|
||||
(unless (memq 'vscroll style)
|
||||
(gtk_widget_hide v2))
|
||||
(values client-gtk h hadj vadj
|
||||
(and (memq 'hscroll style) h2)
|
||||
(and (memq 'vscroll style) v2)
|
||||
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
|
||||
#f)))]
|
||||
[is-combo?
|
||||
(let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
|
||||
[orig-entry (gtk_bin_get_child gtk)])
|
||||
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))]
|
||||
[has-border?
|
||||
(let ([client-gtk (gtk_drawing_area_new)]
|
||||
[h (as-gtk-allocation (gtk_hbox_new #f 0))])
|
||||
(gtk_box_pack_start h client-gtk #t #t 0)
|
||||
(gtk_container_set_border_width h margin)
|
||||
(connect-expose-border h)
|
||||
(gtk_widget_show client-gtk)
|
||||
(values client-gtk h #f #f #f #f #f #f))]
|
||||
[else
|
||||
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
|
||||
(values client-gtk client-gtk #f #f #f #f #f #f))])))
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk gtk]
|
||||
|
|
@ -481,15 +483,15 @@
|
|||
bg-col))
|
||||
(define/public (set-canvas-background col) (set! bg-col col))
|
||||
(define/public (get-canvas-background-for-clearing)
|
||||
;; called in event-dispatch mode
|
||||
(if now-drawing?
|
||||
(begin
|
||||
(set! refresh-after-drawing? #t)
|
||||
#f)
|
||||
(if clear-bg?
|
||||
(let ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))])
|
||||
(unless gc
|
||||
(let ([w (widget-window gtk)])
|
||||
(set! gc (gdk_gc_new w))))
|
||||
(let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
|
||||
[w (widget-window gtk)]
|
||||
[gc (gdk_gc_new w)])
|
||||
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
|
||||
(conv (color-red bg-col))
|
||||
(conv (color-green bg-col))
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
choices style font)
|
||||
(inherit get-gtk set-auto-size)
|
||||
|
||||
(define gtk (gtk_combo_box_new_text))
|
||||
(define gtk (as-gtk-allocation (gtk_combo_box_new_text)))
|
||||
(define count (length choices))
|
||||
|
||||
(for ([l (in-list choices)])
|
||||
|
|
|
|||
|
|
@ -15,6 +15,9 @@
|
|||
|
||||
(define-gtk gtk_progress_bar_new (_fun _pointer -> _GtkWidget))
|
||||
(define-gtk gtk_progress_bar_set_fraction (_fun _GtkWidget _double* -> _void))
|
||||
(define-gtk gtk_progress_bar_set_orientation (_fun _GtkWidget _int -> _void))
|
||||
|
||||
(define GTK_PROGRESS_BOTTOM_TO_TOP 2)
|
||||
|
||||
(defclass gauge% item%
|
||||
(init parent
|
||||
|
|
@ -26,10 +29,13 @@
|
|||
(inherit get-gtk set-auto-size)
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk (gtk_progress_bar_new #f)]
|
||||
[gtk (as-gtk-allocation (gtk_progress_bar_new #f))]
|
||||
[no-show? (memq 'deleted style)])
|
||||
(define gtk (get-gtk))
|
||||
|
||||
(when (memq 'vertical style)
|
||||
(gtk_progress_bar_set_orientation gtk GTK_PROGRESS_BOTTOM_TO_TOP))
|
||||
|
||||
(set-auto-size)
|
||||
|
||||
(define range rng)
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require scheme/class
|
||||
scheme/foreign
|
||||
"../../syntax.rkt"
|
||||
"../../lock.rkt"
|
||||
"window.rkt"
|
||||
"client-window.rkt"
|
||||
"panel.rkt"
|
||||
|
|
@ -29,9 +30,11 @@
|
|||
(inherit set-size set-auto-size infer-client-delta
|
||||
get-gtk get-height)
|
||||
|
||||
(define gtk (gtk_frame_new label))
|
||||
(define client-gtk (gtk_fixed_new))
|
||||
(gtk_container_add gtk client-gtk)
|
||||
(define gtk (as-gtk-allocation (gtk_frame_new label)))
|
||||
(define client-gtk
|
||||
(atomically (let ([client-gtk (gtk_fixed_new)])
|
||||
(gtk_container_add gtk client-gtk)
|
||||
client-gtk)))
|
||||
(gtk_widget_show client-gtk)
|
||||
|
||||
(super-new [parent parent]
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@
|
|||
(define items choices)
|
||||
(define data (map (lambda (c) (box #f)) choices))
|
||||
|
||||
(define store (gtk_list_store_new 1 G_TYPE_STRING))
|
||||
(define store (as-gobject-allocation (gtk_list_store_new 1 G_TYPE_STRING)))
|
||||
(define (reset-content)
|
||||
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
|
||||
(for ([s (in-list items)])
|
||||
|
|
@ -88,23 +88,23 @@
|
|||
(pair? data))
|
||||
(set-selection 0)))
|
||||
|
||||
(define column
|
||||
(let ([renderer (gtk_cell_renderer_text_new)])
|
||||
(gtk_tree_view_column_new_with_attributes
|
||||
"column"
|
||||
renderer
|
||||
"text"
|
||||
0
|
||||
#f)))
|
||||
|
||||
(define gtk (gtk_scrolled_window_new #f #f))
|
||||
(define gtk (as-gtk-allocation (gtk_scrolled_window_new #f #f)))
|
||||
(gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS)
|
||||
|
||||
(define client-gtk
|
||||
(let* ([client-gtk (gtk_tree_view_new_with_model store)])
|
||||
(gtk_tree_view_set_headers_visible client-gtk #f)
|
||||
(gtk_tree_view_append_column client-gtk column)
|
||||
client-gtk))
|
||||
(atomically
|
||||
(let* ([client-gtk (gtk_tree_view_new_with_model store)]
|
||||
[column (let ([renderer (gtk_cell_renderer_text_new)])
|
||||
(gtk_tree_view_column_new_with_attributes
|
||||
"column"
|
||||
renderer
|
||||
"text"
|
||||
0
|
||||
#f))])
|
||||
(gobject-unref store)
|
||||
(gtk_tree_view_set_headers_visible client-gtk #f)
|
||||
(gtk_tree_view_append_column client-gtk column)
|
||||
client-gtk)))
|
||||
|
||||
(gtk_container_add gtk client-gtk)
|
||||
(gtk_widget_show client-gtk)
|
||||
|
|
@ -139,11 +139,12 @@
|
|||
[time-stamp (current-milliseconds)])))))))
|
||||
|
||||
(define/private (get-iter i)
|
||||
(let ([iter (make-GtkTreeIter 0 #f #f #f)]
|
||||
[p (gtk_tree_path_new_from_indices i -1)])
|
||||
(gtk_tree_model_get_iter store iter p)
|
||||
(gtk_tree_path_free p)
|
||||
iter))
|
||||
(atomically
|
||||
(let ([iter (make-GtkTreeIter 0 #f #f #f)]
|
||||
[p (gtk_tree_path_new_from_indices i -1)])
|
||||
(gtk_tree_model_get_iter store iter p)
|
||||
(gtk_tree_path_free p)
|
||||
iter)))
|
||||
|
||||
(def/public-unimplemented get-label-font)
|
||||
|
||||
|
|
@ -155,9 +156,10 @@
|
|||
(gtk_list_store_set store (get-iter i) 0 s -1))
|
||||
|
||||
(define/public (set-first-visible-item i)
|
||||
(let ([p (gtk_tree_path_new_from_indices i -1)])
|
||||
(gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0)
|
||||
(gtk_tree_path_free p)))
|
||||
(atomically
|
||||
(let ([p (gtk_tree_path_new_from_indices i -1)])
|
||||
(gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0)
|
||||
(gtk_tree_path_free p))))
|
||||
|
||||
(define/public (set choices)
|
||||
(atomically
|
||||
|
|
@ -210,10 +212,11 @@
|
|||
(define/public (get-data i) (unbox (list-ref data i)))
|
||||
|
||||
(define/public (selected? i)
|
||||
(let ([p (gtk_tree_path_new_from_indices i -1)])
|
||||
(begin0
|
||||
(gtk_tree_selection_path_is_selected selection p)
|
||||
(gtk_tree_path_free p))))
|
||||
(atomically
|
||||
(let ([p (gtk_tree_path_new_from_indices i -1)])
|
||||
(begin0
|
||||
(gtk_tree_selection_path_is_selected selection p)
|
||||
(gtk_tree_path_free p)))))
|
||||
|
||||
(define/public (select i [on? #t] [extend? #t])
|
||||
(atomically
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require scheme/class
|
||||
scheme/foreign
|
||||
"../../syntax.rkt"
|
||||
"../../lock.rkt"
|
||||
"../common/freeze.rkt"
|
||||
"../common/queue.rkt"
|
||||
"widget.rkt"
|
||||
|
|
@ -73,7 +74,7 @@
|
|||
|
||||
(define menus null)
|
||||
|
||||
(define gtk (gtk_menu_bar_new))
|
||||
(define gtk (as-gtk-allocation (gtk_menu_bar_new)))
|
||||
(super-new [gtk gtk])
|
||||
|
||||
(define/public (get-gtk) gtk)
|
||||
|
|
@ -88,15 +89,16 @@
|
|||
(install-widget-parent top)
|
||||
;; return initial size; also, add a menu to make sure there is one,
|
||||
;; and force the menu bar to be at least that tall always
|
||||
(let ([item (gtk_menu_item_new_with_mnemonic "Xyz")])
|
||||
(gtk_menu_shell_append gtk item)
|
||||
(gtk_widget_show item)
|
||||
(begin0
|
||||
(let ([req (make-GtkRequisition 0 0)])
|
||||
(gtk_widget_size_request gtk req)
|
||||
(gtk_widget_set_usize gtk -1 (GtkRequisition-height req))
|
||||
(GtkRequisition-height req))
|
||||
(gtk_container_remove gtk item))))
|
||||
(atomically
|
||||
(let ([item (gtk_menu_item_new_with_mnemonic "Xyz")])
|
||||
(gtk_menu_shell_append gtk item)
|
||||
(gtk_widget_show item)
|
||||
(begin0
|
||||
(let ([req (make-GtkRequisition 0 0)])
|
||||
(gtk_widget_size_request gtk req)
|
||||
(gtk_widget_set_usize gtk -1 (GtkRequisition-height req))
|
||||
(GtkRequisition-height req))
|
||||
(gtk_container_remove gtk item)))))
|
||||
|
||||
(define/public (get-top-window)
|
||||
top-wx)
|
||||
|
|
@ -129,12 +131,13 @@
|
|||
(public [append-menu append])
|
||||
(define (append-menu menu title)
|
||||
(send menu set-parent this)
|
||||
(let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]
|
||||
[item-wx (new top-menu% [parent this] [gtk item])])
|
||||
(connect-select item)
|
||||
(set! menus (append menus (list (list item menu item-wx))))
|
||||
(let ([gtk (send menu get-gtk)])
|
||||
(g_object_ref gtk)
|
||||
(gtk_menu_item_set_submenu item gtk))
|
||||
(gtk_menu_shell_append gtk item)
|
||||
(gtk_widget_show item))))
|
||||
(atomically
|
||||
(let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]
|
||||
[item-wx (new top-menu% [parent this] [gtk item])])
|
||||
(connect-select item)
|
||||
(set! menus (append menus (list (list item menu item-wx))))
|
||||
(let ([gtk (send menu get-gtk)])
|
||||
(g_object_ref gtk)
|
||||
(gtk_menu_item_set_submenu item gtk))
|
||||
(gtk_menu_shell_append gtk item)
|
||||
(gtk_widget_show item)))))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
"widget.rkt"
|
||||
"window.rkt"
|
||||
"../../syntax.rkt"
|
||||
"../../lock.rkt"
|
||||
"types.rkt"
|
||||
"const.rkt"
|
||||
"utils.rkt"
|
||||
|
|
@ -80,7 +81,7 @@
|
|||
|
||||
(define cb callback)
|
||||
|
||||
(define gtk (gtk_menu_new))
|
||||
(define gtk (as-gtk-allocation (gtk_menu_new)))
|
||||
(define/public (get-gtk) gtk)
|
||||
|
||||
(super-new [gtk gtk])
|
||||
|
|
@ -175,34 +176,36 @@
|
|||
|
||||
(public [append-item append])
|
||||
(define (append-item i label help-str-or-submenu chckable?)
|
||||
(let ([item-gtk ((if chckable?
|
||||
gtk_check_menu_item_new_with_mnemonic
|
||||
gtk_menu_item_new_with_mnemonic)
|
||||
(fixup-mneumonic label))])
|
||||
(if (help-str-or-submenu . is-a? . menu%)
|
||||
(let ([submenu help-str-or-submenu])
|
||||
(let ([gtk (send submenu get-gtk)])
|
||||
(g_object_ref gtk)
|
||||
(gtk_menu_item_set_submenu item-gtk gtk)
|
||||
(send submenu set-parent this)
|
||||
(send submenu set-self-item i
|
||||
(lambda () (gtk_menu_item_set_submenu item-gtk #f)))
|
||||
(set! items (append items (list (list submenu item-gtk label chckable?))))))
|
||||
(let ([item (new menu-item-handler%
|
||||
[gtk item-gtk]
|
||||
[menu this]
|
||||
[menu-item i]
|
||||
[parent this])])
|
||||
(set! items (append items (list (list item item-gtk label chckable?))))
|
||||
(adjust-shortcut item-gtk label)))
|
||||
(gtk_menu_shell_append gtk item-gtk)
|
||||
(gtk_widget_show item-gtk)))
|
||||
(atomically
|
||||
(let ([item-gtk ((if chckable?
|
||||
gtk_check_menu_item_new_with_mnemonic
|
||||
gtk_menu_item_new_with_mnemonic)
|
||||
(fixup-mneumonic label))])
|
||||
(if (help-str-or-submenu . is-a? . menu%)
|
||||
(let ([submenu help-str-or-submenu])
|
||||
(let ([gtk (send submenu get-gtk)])
|
||||
(g_object_ref gtk)
|
||||
(gtk_menu_item_set_submenu item-gtk gtk)
|
||||
(send submenu set-parent this)
|
||||
(send submenu set-self-item i
|
||||
(lambda () (gtk_menu_item_set_submenu item-gtk #f)))
|
||||
(set! items (append items (list (list submenu item-gtk label chckable?))))))
|
||||
(let ([item (new menu-item-handler%
|
||||
[gtk item-gtk]
|
||||
[menu this]
|
||||
[menu-item i]
|
||||
[parent this])])
|
||||
(set! items (append items (list (list item item-gtk label chckable?))))
|
||||
(adjust-shortcut item-gtk label)))
|
||||
(gtk_menu_shell_append gtk item-gtk)
|
||||
(gtk_widget_show item-gtk))))
|
||||
|
||||
(define/public (append-separator)
|
||||
(let ([item-gtk (gtk_separator_menu_item_new)])
|
||||
(set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f))))
|
||||
(gtk_menu_shell_append gtk item-gtk)
|
||||
(gtk_widget_show item-gtk)))
|
||||
(atomically
|
||||
(let ([item-gtk (gtk_separator_menu_item_new)])
|
||||
(set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f))))
|
||||
(gtk_menu_shell_append gtk item-gtk)
|
||||
(gtk_widget_show item-gtk))))
|
||||
|
||||
(def/public-unimplemented select)
|
||||
(def/public-unimplemented get-font)
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@
|
|||
(inherit set-size get-gtk)
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk (gtk_fixed_new)] ; (gtk_alignment_new 0.0 0.0 1.0 1.0)]
|
||||
[gtk (as-gtk-allocation (gtk_fixed_new))]
|
||||
[no-show? (memq 'deleted style)])
|
||||
|
||||
(define gtk (get-gtk))
|
||||
|
|
|
|||
|
|
@ -44,26 +44,28 @@
|
|||
(inherit set-auto-size
|
||||
on-set-focus)
|
||||
|
||||
(define gtk (if (memq 'horizontal style)
|
||||
(gtk_hbox_new #f 0)
|
||||
(gtk_vbox_new #f 0)))
|
||||
(define gtk (as-gtk-allocation
|
||||
(if (memq 'horizontal style)
|
||||
(gtk_hbox_new #f 0)
|
||||
(gtk_vbox_new #f 0))))
|
||||
(define radio-gtks (for/list ([lbl (in-list labels)])
|
||||
(let ([radio-gtk (cond
|
||||
[(string? lbl)
|
||||
(gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))]
|
||||
[(send lbl ok?)
|
||||
(let ([pixbuf (bitmap->pixbuf lbl)])
|
||||
(let ([radio-gtk (gtk_radio_button_new #f)]
|
||||
[image-gtk (gtk_image_new_from_pixbuf pixbuf)])
|
||||
(release-pixbuf pixbuf)
|
||||
(gtk_container_add radio-gtk image-gtk)
|
||||
(gtk_widget_show image-gtk)
|
||||
radio-gtk))]
|
||||
[else
|
||||
(gtk_radio_button_new_with_mnemonic #f "<bad bitmap>")])])
|
||||
(gtk_box_pack_start gtk radio-gtk #t #t 0)
|
||||
(gtk_widget_show radio-gtk)
|
||||
radio-gtk)))
|
||||
(atomically
|
||||
(let ([radio-gtk (cond
|
||||
[(string? lbl)
|
||||
(gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))]
|
||||
[(send lbl ok?)
|
||||
(let ([pixbuf (bitmap->pixbuf lbl)])
|
||||
(let ([radio-gtk (gtk_radio_button_new #f)]
|
||||
[image-gtk (gtk_image_new_from_pixbuf pixbuf)])
|
||||
(release-pixbuf pixbuf)
|
||||
(gtk_container_add radio-gtk image-gtk)
|
||||
(gtk_widget_show image-gtk)
|
||||
radio-gtk))]
|
||||
[else
|
||||
(gtk_radio_button_new_with_mnemonic #f "<bad bitmap>")])])
|
||||
(gtk_box_pack_start gtk radio-gtk #t #t 0)
|
||||
(gtk_widget_show radio-gtk)
|
||||
radio-gtk))))
|
||||
(for ([radio-gtk (in-list (cdr radio-gtks))])
|
||||
(let ([g (gtk_radio_button_get_group (car radio-gtks))])
|
||||
(gtk_radio_button_set_group radio-gtk g)))
|
||||
|
|
@ -108,8 +110,9 @@
|
|||
(if (= i -1)
|
||||
(when (pair? radio-gtks)
|
||||
(unless dummy-gtk
|
||||
(set! dummy-gtk (gtk_radio_button_new
|
||||
(gtk_radio_button_get_group (car radio-gtks)))))
|
||||
(set! dummy-gtk (as-gtk-allocation
|
||||
(gtk_radio_button_new
|
||||
(gtk_radio_button_get_group (car radio-gtks))))))
|
||||
(gtk_toggle_button_set_active dummy-gtk #t))
|
||||
(gtk_toggle_button_set_active (list-ref radio-gtks i) #t))
|
||||
(set! no-clicked? #f)))
|
||||
|
|
|
|||
|
|
@ -39,9 +39,10 @@
|
|||
(inherit get-gtk set-auto-size)
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk (if (memq 'vertical style)
|
||||
(gtk_vscale_new #f)
|
||||
(gtk_hscale_new #f))]
|
||||
[gtk (as-gtk-allocation
|
||||
(if (memq 'vertical style)
|
||||
(gtk_vscale_new #f)
|
||||
(gtk_hscale_new #f)))]
|
||||
[callback cb]
|
||||
[no-show? (memq 'deleted style)])
|
||||
(define gtk (get-gtk))
|
||||
|
|
|
|||
|
|
@ -17,6 +17,10 @@
|
|||
g_object_ref
|
||||
g_object_unref
|
||||
|
||||
gobject-ref
|
||||
gobject-unref
|
||||
as-gobject-allocation
|
||||
|
||||
as-gtk-allocation
|
||||
as-gtk-window-allocation
|
||||
|
||||
|
|
@ -90,6 +94,14 @@
|
|||
(define-gobj g_object_unref (_fun _pointer -> _void))
|
||||
(define-gobj g_object_ref_sink (_fun _pointer -> _pointer))
|
||||
|
||||
(define gobject-unref ((deallocator) g_object_unref))
|
||||
(define gobject-ref ((allocator gobject-unref) g_object_ref))
|
||||
|
||||
(define-syntax-rule (as-gobject-allocation expr)
|
||||
((gobject-allocator (lambda () expr))))
|
||||
|
||||
(define gobject-allocator (allocator gobject-unref))
|
||||
|
||||
(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void))
|
||||
|
||||
(define gtk-destroy ((deallocator) (lambda (v)
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
#lang scheme/base
|
||||
(require scheme/foreign
|
||||
scheme/class
|
||||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
racket/class
|
||||
"../../syntax.rkt"
|
||||
"../../lock.rkt"
|
||||
"../common/queue.rkt"
|
||||
"queue.rkt"
|
||||
"utils.rkt"
|
||||
"types.rkt")
|
||||
(unsafe!)
|
||||
|
||||
(provide widget%
|
||||
gtk->wx
|
||||
|
|
@ -25,13 +25,17 @@
|
|||
|
||||
(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
|
||||
|
|
@ -52,10 +56,12 @@
|
|||
|
||||
(super-new)
|
||||
|
||||
(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)))))
|
||||
(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")])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user