suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gtk: fix border (when requested) for canvas% with scrollbars

Browse Source
This commit is contained in:
Matthew Flatt 2011-09-01 07:06:39 -06:00
parent 3f11ef9b11
commit 9d5f45a9d1
3 changed files with 16 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -280,7 +280,8 @@
(unless (eq? client-gtk container-gtk) (unless (eq? client-gtk container-gtk)
(gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping (gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping
(when has-border? (when has-border?
(gtk_container_set_border_width h margin)) (gtk_container_set_border_width h margin)
(connect-expose-border h))
(gtk_box_pack_start h v #t #t 0) (gtk_box_pack_start h v #t #t 0)
(gtk_box_pack_start v client-gtk #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 h v2 #f #f 0)

18
collects/mred/private/wx/gtk/panel.rkt
View File

@ -35,14 +35,16 @@
[gray #x8000]) [gray #x8000])
(when gc (when gc
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray)) (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray))
(let ([a (widget-allocation gtk)] (let* ([a (widget-allocation gtk)]
[no-window? (not (zero? (bitwise-and (get-gtk-object-flags gtk) [w (sub1 (GtkAllocation-width a))]
GTK_NO_WINDOW)))]) [h (sub1 (GtkAllocation-height a))])
(gdk_draw_rectangle win gc #f (let loop ([gtk gtk] [x 0] [y 0])
(if no-window? (GtkAllocation-x a) 0) (if (not (zero? (bitwise-and (get-gtk-object-flags gtk) GTK_NO_WINDOW)))
(if no-window? (GtkAllocation-y a) 0) ;; no window:
(sub1 (GtkAllocation-width a)) (let ([a (widget-allocation gtk)])
(sub1 (GtkAllocation-height a)))) (loop (widget-parent gtk) (+ x (GtkAllocation-x a)) (+ y (GtkAllocation-y a))))
;; found window:
(gdk_draw_rectangle win gc #f x y w h))))
(gdk_gc_unref gc))) (gdk_gc_unref gc)))
#f)) #f))

4
collects/mred/private/wx/gtk/window.rkt
View File

@ -42,6 +42,7 @@
widget-window widget-window
widget-allocation widget-allocation
widget-parent
the-accelerator-group the-accelerator-group
gtk_window_add_accel_group gtk_window_add_accel_group
@ -105,6 +106,9 @@
(define (widget-window gtk) (define (widget-window gtk)
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define (widget-parent gtk)
(GtkWidgetT-parent (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define (widget-allocation gtk) (define (widget-allocation gtk)
(GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer))) (GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer)))