fix problems with gtk canvas client size and with checkable menus
original commit: 6772afbd2eca2c2e145cd81e9d3dadaa6c1412f7
This commit is contained in:
Matthew Flatt
parent
7213e034c3
commit
f7caa3965b
|
|
@ -185,7 +185,8 @@
|
|||
|
||||
(inherit get-gtk set-size get-size get-client-size
|
||||
on-size get-top-win
|
||||
set-auto-size adjust-client-delta)
|
||||
set-auto-size
|
||||
adjust-client-delta infer-client-delta)
|
||||
|
||||
(define is-combo? (memq 'combo style))
|
||||
(define has-border? (or (memq 'border style)
|
||||
|
|
@ -199,7 +200,8 @@
|
|||
|
||||
(define-values (client-gtk gtk
|
||||
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
|
||||
combo-button-gtk)
|
||||
combo-button-gtk
|
||||
scroll-width)
|
||||
(atomically ;; need to connect all children to gtk to avoid leaks
|
||||
(cond
|
||||
[(or (memq 'hscroll style)
|
||||
|
|
@ -214,6 +216,13 @@
|
|||
[hscroll (gtk_hscrollbar_new hadj)]
|
||||
[vscroll (gtk_vscrollbar_new vadj)]
|
||||
[resize-box (gtk_drawing_area_new)])
|
||||
;; |------------------------------------|
|
||||
;; | h |-----------------| |-----------||
|
||||
;; | | v | | v2 ||
|
||||
;; | | | | [vscroll] ||
|
||||
;; | | [h2 [hscroll]] | | [resize] ||
|
||||
;; | |-----------------| |-----------||
|
||||
;; |------------------------------------|
|
||||
(when has-border?
|
||||
(gtk_container_set_border_width h margin))
|
||||
(gtk_box_pack_start h v #t #t 0)
|
||||
|
|
@ -223,28 +232,29 @@
|
|||
(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)
|
||||
(when (memq 'hscroll style)
|
||||
(gtk_widget_show hscroll))
|
||||
(gtk_widget_show vscroll)
|
||||
(gtk_widget_show h)
|
||||
(gtk_widget_show v)
|
||||
(gtk_widget_show v2)
|
||||
(when (memq 'vscroll style)
|
||||
(gtk_widget_show v2))
|
||||
(gtk_widget_show h2)
|
||||
(gtk_widget_show resize-box)
|
||||
(when (memq 'hscroll style)
|
||||
(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)))]
|
||||
(let ([req (make-GtkRequisition 0 0)])
|
||||
(gtk_widget_size_request vscroll req)
|
||||
(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
|
||||
(GtkRequisition-width req)))))]
|
||||
[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)))]
|
||||
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
|
||||
[has-border?
|
||||
(let ([client-gtk (gtk_drawing_area_new)]
|
||||
[h (as-gtk-allocation (gtk_hbox_new #f 0))])
|
||||
|
|
@ -252,10 +262,10 @@
|
|||
(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))]
|
||||
(values client-gtk h #f #f #f #f #f #f 0))]
|
||||
[else
|
||||
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
|
||||
(values client-gtk client-gtk #f #f #f #f #f #f))])))
|
||||
(values client-gtk client-gtk #f #f #f #f #f #f 0))])))
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk gtk]
|
||||
|
|
@ -268,9 +278,9 @@
|
|||
(if combo-button-gtk
|
||||
(list client-gtk combo-button-gtk)
|
||||
(list client-gtk))))])
|
||||
|
||||
(set-size x y w h)
|
||||
|
||||
(set-size x y w h)
|
||||
|
||||
(define dc (new dc% [canvas this]))
|
||||
|
||||
(gtk_widget_realize gtk)
|
||||
|
|
@ -303,7 +313,14 @@
|
|||
(when vscroll-adj (connect-value-changed-v vscroll-adj))
|
||||
|
||||
(set-auto-size)
|
||||
(adjust-client-delta margin margin)
|
||||
(adjust-client-delta (+ (* 2 margin)
|
||||
(if (memq 'vscroll style)
|
||||
scroll-width
|
||||
0))
|
||||
(+ (* 2 margin)
|
||||
(if (memq 'hscroll style)
|
||||
scroll-width
|
||||
0)))
|
||||
|
||||
(define/override (direct-update?) #f)
|
||||
|
||||
|
|
@ -400,7 +417,9 @@
|
|||
(gtk_widget_show resize-box)]
|
||||
[(and v? (not h?))
|
||||
;; remove corner
|
||||
(gtk_widget_hide resize-box)])))
|
||||
(gtk_widget_hide resize-box)]))
|
||||
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
|
||||
(+ (* 2 margin) (if h? scroll-width 0))))
|
||||
|
||||
(define/private (configure-adj adj scroll-gtk len page pos)
|
||||
(when (and scroll-gtk adj)
|
||||
|
|
|
|||
|
|
@ -29,12 +29,8 @@
|
|||
(class %
|
||||
(init client-gtk)
|
||||
|
||||
(inherit remember-client-size)
|
||||
|
||||
(connect-size-allocate client-gtk)
|
||||
|
||||
(define client-w 0)
|
||||
(define client-h 0)
|
||||
(define client-x 0)
|
||||
(define client-y 0)
|
||||
|
||||
|
|
@ -44,9 +40,6 @@
|
|||
;; Called in the Gtk event-loop thread
|
||||
(set! client-x x)
|
||||
(set! client-y y)
|
||||
(set! client-w w)
|
||||
(set! client-h h)
|
||||
(remember-client-size w h)
|
||||
(queue-window-event this (lambda ()
|
||||
(internal-on-client-size w h)
|
||||
(on-client-size w h))))
|
||||
|
|
@ -54,15 +47,6 @@
|
|||
(define/public (internal-on-client-size w h)
|
||||
(void))
|
||||
|
||||
(define/override (tentative-client-size w h)
|
||||
(set! client-w w)
|
||||
(set! client-h h))
|
||||
|
||||
#;
|
||||
(define/override (get-client-size xb yb)
|
||||
(set-box! xb client-w)
|
||||
(set-box! yb client-h))
|
||||
|
||||
(define/override (get-client-delta)
|
||||
(values client-x client-y))
|
||||
|
||||
|
|
|
|||
|
|
@ -129,23 +129,26 @@
|
|||
0
|
||||
(gtk_get_current_event_time)))
|
||||
|
||||
(define ignore-callback? #f)
|
||||
|
||||
(define/public (do-selected menu-item)
|
||||
;; Called in event-pump thread
|
||||
(let ([top (get-top-parent)])
|
||||
(cond
|
||||
[top
|
||||
(queue-window-event
|
||||
top
|
||||
(lambda () (send top on-menu-command menu-item)))]
|
||||
[on-popup
|
||||
(let* ([e (new popup-event% [event-type 'menu-popdown])]
|
||||
[pu on-popup]
|
||||
[cnb cancel-none-box])
|
||||
(set! on-popup #f)
|
||||
(set-box! cancel-none-box #t)
|
||||
(send e set-menu-id menu-item)
|
||||
(pu (lambda () (cb this e))))]
|
||||
[parent (send parent do-selected menu-item)])))
|
||||
(unless ignore-callback?
|
||||
(let ([top (get-top-parent)])
|
||||
(cond
|
||||
[top
|
||||
(queue-window-event
|
||||
top
|
||||
(lambda () (send top on-menu-command menu-item)))]
|
||||
[on-popup
|
||||
(let* ([e (new popup-event% [event-type 'menu-popdown])]
|
||||
[pu on-popup]
|
||||
[cnb cancel-none-box])
|
||||
(set! on-popup #f)
|
||||
(set-box! cancel-none-box #t)
|
||||
(send e set-menu-id menu-item)
|
||||
(pu (lambda () (cb this e))))]
|
||||
[parent (send parent do-selected menu-item)]))))
|
||||
|
||||
(define/public (do-no-selected)
|
||||
;; Queue a none-selected event, but only tentatively, because
|
||||
|
|
@ -237,7 +240,10 @@
|
|||
(define/public (check item on?)
|
||||
(let ([gtk (find-gtk item)])
|
||||
(when gtk
|
||||
(gtk_check_menu_item_set_active gtk on?))))
|
||||
(atomically
|
||||
(set! ignore-callback? #t)
|
||||
(gtk_check_menu_item_set_active gtk on?)
|
||||
(set! ignore-callback? #f)))))
|
||||
|
||||
(define/public (checked? item)
|
||||
(let ([gtk (find-gtk item)])
|
||||
|
|
|
|||
|
|
@ -338,8 +338,6 @@
|
|||
(unless (= h -1) (set! save-h h))
|
||||
(set! save-w (max save-w client-delta-w))
|
||||
(set! save-h (max save-h client-delta-h))
|
||||
(tentative-client-size (+ save-w client-delta-w)
|
||||
(+ save-h client-delta-h))
|
||||
(really-set-size gtk save-x save-y save-w save-h)))
|
||||
|
||||
(define/public (save-size x y w h)
|
||||
|
|
@ -368,16 +366,6 @@
|
|||
|
||||
(define client-delta-w 0)
|
||||
(define client-delta-h 0)
|
||||
(define min-client-delta-w 0)
|
||||
(define min-client-delta-h 0)
|
||||
(define/public (remember-client-size w h)
|
||||
;; Called in the Gtk event-loop thread
|
||||
;(set! client-delta-w (max min-client-delta-w (- save-w w)))
|
||||
;(set! client-delta-h (max min-client-delta-h (- save-h h)))
|
||||
#;(queue-window-event this (lambda () (on-size 0 0)))
|
||||
(void))
|
||||
(define/public (tentative-client-size w h)
|
||||
(void))
|
||||
|
||||
(define/public (adjust-client-delta dw dh)
|
||||
(set! client-delta-w dw)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user