suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
2a0fc3652f
gui/gui-lib/mred/private/wx/gtk/frame.rkt
Matthew Flatt b06ee46854 GTK+ 3: fix client->global in a frame with a menu bar 
It seems that the right answer was produced in GTK+ 2 due to a
client-location callback, but change the code to use the intended
approach of tracking the menu height.
2015-08-21 16:19:47 -06:00

661 lines
23 KiB
Racket
Raw Blame History

#lang racket/base
(require ffi/unsafe
racket/class
racket/promise
racket/runtime-path
racket/draw
(for-syntax (only-in racket/base quote))
"../../syntax.rkt"
"../../lock.rkt"
"utils.rkt"
"const.rkt"
"types.rkt"
"window.rkt"
"client-window.rkt"
"widget.rkt"
"cursor.rkt"
"pixbuf.rkt"
"resolution.rkt"
"../common/queue.rkt")
(provide
(protect-out frame%
display-origin
display-size
display-count
display-bitmap-resolution
location->window
get-current-mouse-state))
;; ----------------------------------------
(define GDK_GRAVITY_NORTH_WEST 1)
(define GDK_GRAVITY_STATIC 10)
(define _GList (_cpointer/null 'GList))
(define-glib g_list_insert (_fun _GList _pointer _int -> _GList))
(define-glib g_list_free (_fun _GList -> _void))
(define-gtk gtk_window_new (_fun _int -> _GtkWidget))
(define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-gtk gtk_window_get_size (_fun _GtkWidget (w : (_ptr o _int)) (h : (_ptr o _int))
-> _void
-> (values w h)))
(define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_window_set_keep_above (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_window_set_focus_on_map (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_window_maximize (_fun _GtkWidget -> _void))
(define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void))
(define-gtk gtk_window_move (_fun _GtkWidget _int _int -> _void))
(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void)
#:fail (lambda () (lambda (w x y) (gtk_window_move w x y))))
(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int))
-> _void
-> (values x y)))
(define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void))
(define-gtk gtk_window_set_icon_list (_fun _GtkWindow _GList -> _void))
(define-gtk gtk_window_fullscreen (_fun _GtkWindow -> _void))
(define-gtk gtk_window_unfullscreen (_fun _GtkWindow -> _void))
(define-gtk gtk_window_get_focus (_fun _GtkWindow -> (_or-null _GtkWidget)))
(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow))
(define-gdk gdk_screen_get_monitor_scale_factor (_fun _GdkScreen _int -> _int)
#:fail (lambda () (lambda (s n) 1)))
(define-gdk gdk_window_get_pointer (_fun _GdkWindow
(x : (_ptr o _int))
(y : (_ptr o _int))
(mods : (_ptr o _uint))
-> _GdkWindow
-> (values x y mods)))
(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
(define-cstruct _GdkGeometry ([min_width _int]
[min_height _int]
[max_width _int]
[max_height _int]
[base_width _int]
[base_height _int]
[width_inc _int]
[height_inc _int]
[min_aspect _double]
[max_aspect _double]
[win_gravity _int]))
(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void))
(define-gtk gtk_layout_new (_fun (_pointer = #f) (_pointer = #f) -> _GtkWidget))
(define-gtk gtk_layout_put (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-signal-handler connect-delete "delete-event"
(_fun _GtkWidget -> _gboolean)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(when wx
(queue-window-event wx (lambda ()
(unless (other-modal? wx)
(when (send wx on-close)
(send wx direct-show #f)))))))))
(define-signal-handler connect-configure "configure-event"
(_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean)
(lambda (gtk a)
(let ([wx (gtk->wx gtk)])
(when wx
(send wx remember-size
(->normal (GdkEventConfigure-x a))
(->normal (GdkEventConfigure-y a))
(->normal (GdkEventConfigure-width a))
(->normal (GdkEventConfigure-height a)))))
#f))
(define-cstruct _GdkEventWindowState ([type _int]
[window _GtkWindow]
[send_event _int8]
[changed_mask _int]
[new_window_state _int]))
(define-signal-handler connect-window-state "window-state-event"
(_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean)
(lambda (gtk evt)
(let ([wx (gtk->wx gtk)])
(when wx
(send wx on-window-state
(GdkEventWindowState-changed_mask evt)
(GdkEventWindowState-new_window_state evt))))
#f))
(define-runtime-path plt-16x16-file '(lib "icons/plt-16x16.png"))
(define-runtime-path plt-32x32-file '(lib "icons/plt-32x32.png"))
(define-runtime-path plt-48x48-file '(lib "icons/plt-48x48.png"))
(define icon-pixbufs+glist
(delay
(let ([icons (map
(lambda (fn)
(bitmap->pixbuf (make-object bitmap% fn 'png/alpha)))
(list plt-16x16-file
plt-32x32-file
plt-48x48-file))])
(cons
;; keep pixbuf pointers to avoid GC:
icons
;; a glist:
(for/fold ([l #f]) ([i (in-list icons)])
(g_list_insert l i -1))))))
;; used for location->window
(define all-frames (make-weak-hasheq))
(define frame%
(class (client-size-mixin window%)
(init parent
label
x y w h
style)
(init [is-dialog? #f])
(inherit get-gtk set-size
pre-on-char pre-on-event
get-stored-client-delta get-size
get-parent get-eventspace
adjust-client-delta
queue-on-size)
(define floating? (memq 'float style))
(define gtk (as-gtk-window-allocation
(gtk_window_new (if floating?
GTK_WINDOW_POPUP
GTK_WINDOW_TOPLEVEL))))
(when (memq 'no-caption style)
(gtk_window_set_decorated gtk #f))
(when floating?
(gtk_window_set_keep_above gtk #t)
(gtk_window_set_focus_on_map gtk #f))
(define-values (vbox-gtk layout-gtk panel-gtk)
(atomically
(let ([vbox-gtk (gtk_vbox_new #f 0)]
[layout-gtk (and gtk3? (gtk_layout_new))]
[panel-gtk (gtk_fixed_new)])
(gtk_container_add gtk vbox-gtk)
(gtk_box_pack_end vbox-gtk (or layout-gtk panel-gtk) #t #t 0)
(when layout-gtk
(gtk_layout_put layout-gtk panel-gtk 0 0))
(values vbox-gtk layout-gtk panel-gtk))))
(gtk_widget_show vbox-gtk)
(when layout-gtk (gtk_widget_show layout-gtk))
(gtk_widget_show panel-gtk)
(connect-enter-and-leave gtk)
;; Enable key events on the panel to catch events
;; that would otherwise go undelivered:
(gtk_widget_set_can_focus panel-gtk #t)
(gtk_widget_add_events panel-gtk (bitwise-ior GDK_KEY_PRESS_MASK
GDK_KEY_RELEASE_MASK))
(connect-key panel-gtk)
(unless is-dialog?
(gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist))))
(define/override (get-client-gtk) panel-gtk)
(define/override (get-window-gtk) gtk)
(define/override (in-floating?) floating?)
(super-new [parent parent]
[gtk gtk]
[client-gtk panel-gtk]
[no-show? #t]
[add-to-parent? #f]
[extra-gtks (list panel-gtk)]
[connect-size-allocate? #f])
(set-size x y w h)
(when (memq 'hide-menu-bar style)
(gtk_window_fullscreen gtk))
(connect-delete gtk)
(connect-configure gtk)
(connect-focus gtk)
(connect-window-state gtk)
(define saved-title (or label ""))
(define is-modified? #f)
(when label
(gtk_window_set_title gtk label))
;(gtk_window_add_accel_group (widget-window gtk) the-accelerator-group)
(define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move panel-gtk child-gtk (->screen x) (->screen y))
(gtk_widget_set_size_request child-gtk (->screen w) (->screen h)))
(define/public (on-close) #t)
(define/public (set-menu-bar mb)
(let ([mb-gtk (send mb get-gtk)])
(gtk_box_pack_start vbox-gtk mb-gtk #f #f 0)
(gtk_widget_show mb-gtk))
(let ([h (send mb set-top-window this)])
;; adjust client delta right away, so that we make
;; better assumptions about the client size and more
;; quickly converge to the right size of the frame
;; based on its content
(adjust-client-delta 0 h))
;; Hack: calls back into the mred layer to re-compute
;; sizes. By calling this early enough, the frame won't
;; grow if it doesn't have to grow to accommodate the menu bar.
(send this resized))
(define/public (reset-menu-height h)
(adjust-client-delta 0 h))
(define saved-enforcements (vector 0 0 -1 -1))
(define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
(define (to-max v) (if (= v -1) #x3FFFFF (->screen v)))
(set! saved-enforcements (vector min-x min-y max-x max-y))
(gtk_window_set_geometry_hints gtk gtk
(make-GdkGeometry (->screen min-x) (->screen min-y)
(to-max max-x) (to-max max-y)
0 0
(->screen inc-x) (->screen inc-y)
0.0 0.0
0)
(bitwise-ior GDK_HINT_MIN_SIZE
GDK_HINT_MAX_SIZE
GDK_HINT_RESIZE_INC)))
(define/override (get-top-win) this)
(define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1)))
(define/public (get-dc-lock) dc-lock)
(define/override (get-dialog-level) 0)
(define/public (frame-relative-dialog-status win) #f)
(define/override (get-unset-pos) #f)
(define/override (center dir wrt)
(let ([w-box (box 0)]
[h-box (box 0)]
[sx-box (box 0)]
[sy-box (box 0)]
[sw-box (box 0)]
[sh-box (box 0)])
(get-size w-box h-box)
(let ([p (get-parent)])
(if p
(begin
(send p get-size sw-box sh-box)
(set-box! sx-box (send p get-x))
(set-box! sy-box (send p get-y)))
(display-size sw-box sh-box #t 0 void)))
(let* ([sw (unbox sw-box)]
[sh (unbox sh-box)]
[fw (unbox w-box)]
[fh (unbox h-box)])
(set-top-position (if (or (eq? dir 'both)
(eq? dir 'horizontal))
(+ (unbox sx-box) (quotient (- sw fw) 2))
#f)
(if (or (eq? dir 'both)
(eq? dir 'vertical))
(+ (unbox sy-box) (quotient (- sh fh) 2))
#f)))))
(define/public (set-top-position x y)
(unless (and (not x) (not y))
(gtk_widget_set_uposition gtk
(or (and x (->screen x)) -2)
(or (and y (->screen y)) -2))))
(define/override (really-set-size gtk x y processed-x processed-y w h)
(set-top-position x y)
(gtk_window_resize gtk (max 1 (->screen w)) (max 1 (->screen h))))
(define/override (show on?)
(let ([es (get-eventspace)])
(when (and on?
(eventspace-shutdown? es))
(error (string->symbol
(format "show method in ~a"
(if (frame-relative-dialog-status this)
'dialog%
'frame%)))
"eventspace has been shutdown")
(when saved-child
(if (eq? (current-thread) (eventspace-handler-thread es))
(send saved-child paint-children)
(let ([s (make-semaphore)])
(queue-callback (lambda ()
(when saved-child
(send saved-child paint-children))
(semaphore-post s)))
(sync/timeout 1 s))))))
(super show on?))
(define saved-child #f)
(define/override (register-child child on?)
(unless on? (error 'register-child-in-frame "did not expect #f"))
(unless (or (not saved-child) (eq? child saved-child))
(error 'register-child-in-frame "expected only one child"))
(set! saved-child child))
(define/override (register-child-in-parent on?)
(void))
(define/override (refresh-all-children)
(when saved-child
(send saved-child refresh)))
(define/override (direct-show on?)
;; atomic mode
(if on?
(hash-set! all-frames this #t)
(hash-remove! all-frames this))
(super direct-show on?)
(when on? (gtk_window_deiconify gtk))
(register-frame-shown this on?))
(define/public (destroy)
;; atomic mode
(direct-show #f))
(define/override (on-client-size w h)
(void))
(define/augment (is-enabled-to-root?) #t)
(define big-icon #f)
(define small-icon #f)
(define/public (set-icon bm [mask #f] [mode 'both])
(let ([bm (if mask
(let* ([nbm (make-object bitmap%
(send bm get-width)
(send bm get-height)
#f
#t)]
[dc (make-object bitmap-dc% nbm)])
(send dc draw-bitmap bm 0 0
'solid (make-object color% "black")
mask)
(send dc set-bitmap #f)
nbm)
bm)])
(case mode
[(small) (set! small-icon bm)]
[(big) (set! big-icon bm)]
[(both)
(set! small-icon bm)
(set! big-icon bm)])
(let ([small-pixbuf
(if small-icon
(bitmap->pixbuf small-icon)
(car (car (force icon-pixbufs+glist))))]
[big-pixbufs
(if big-icon
(list (bitmap->pixbuf big-icon))
(cdr (car (force icon-pixbufs+glist))))])
(atomically
(let ([l (for/fold ([l #f]) ([i (cons small-pixbuf big-pixbufs)])
(g_list_insert l i -1))])
(gtk_window_set_icon_list gtk l)
(g_list_free l))))))
(define child-has-focus? #f)
(define reported-activate #f)
(define queued-active? #f)
(define/public (on-focus-child on?)
;; atomic mode
(set! child-has-focus? on?)
(unless queued-active?
(set! queued-active? #t)
(queue-window-event this
(lambda ()
(let ([on? child-has-focus?])
(set! queued-active? #f)
(unless (eq? on? reported-activate)
(set! reported-activate on?)
(on-activate on?)))))))
(define treat-focus-out-as-menu-click? #f)
(define/public (treat-focus-out-as-menu-click)
(set! treat-focus-out-as-menu-click? #t))
(define focus-here? #f)
(define/override (on-focus? on?)
(when (and (not on?) treat-focus-out-as-menu-click?)
(on-menu-click))
(on-focus-child on?)
(cond
[on?
(if (ptr-equal? (gtk_window_get_focus gtk) gtk)
(begin
(set! focus-here? #t)
(super on-focus? on?))
#f)]
[focus-here?
(set! focus-here? #f)
(super on-focus? on?)]
[else #f]))
(define/public (get-focus-window [even-if-not-active? #f])
(let ([f-gtk (gtk_window_get_focus gtk)])
(and f-gtk
(or even-if-not-active?
(gtk_widget_has_focus f-gtk))
(gtk->wx f-gtk))))
(define/override (call-pre-on-event w e)
(pre-on-event w e))
(define/override (call-pre-on-char w e)
(pre-on-char w e))
(define/override (internal-client-to-screen x y)
(gtk_window_set_gravity gtk GDK_GRAVITY_STATIC)
(let-values ([(dx dy) (gtk_window_get_position gtk)]
[(cdx cdy) (get-stored-client-delta)])
(gtk_window_set_gravity gtk GDK_GRAVITY_NORTH_WEST)
(set-box! x (+ (unbox x) (->normal (+ dx cdx))))
(set-box! y (+ (unbox y) (->normal (+ dy cdy))))))
(define/public (on-toolbar-click) (void))
(define/public (on-menu-click) (void))
(define/public (on-menu-command c) (void))
(def/public-unimplemented on-mdi-activate)
(define/public (on-activate on?) (void))
(define/public (designate-root-frame) (void))
(def/public-unimplemented system-menu)
(define/public (set-modified mod?)
(unless (eq? is-modified? (and mod? #t))
(set! is-modified? (and mod? #t))
(set-title saved-title)))
(define waiting-cursor? #f)
(define/public (set-wait-cursor-mode on?)
(set! waiting-cursor? on?)
(when in-window
(send in-window enter-window)))
(define current-cursor-handle #f)
(define in-window #f)
(define/override (set-parent-window-cursor in-win c)
(set! in-window in-win)
(let ([c (if waiting-cursor?
(get-watch-cursor-handle)
c)])
(unless (eq? c current-cursor-handle)
(atomically
(set! current-cursor-handle c)
(gdk_window_set_cursor (widget-window (get-gtk)) (if (eq? c (get-arrow-cursor-handle))
#f
c))))))
(define/override (enter-window) (void))
(define/override (leave-window) (void))
(define/override (check-window-cursor win)
(when in-window
(send in-window enter-window)))
(define maximized? #f)
(define is-iconized? #f)
(define fullscreen? #f)
(define/public (is-maximized?)
maximized?)
(define/public (maximize on?)
((if on? gtk_window_maximize gtk_window_unmaximize) gtk))
(define/public (on-window-state changed value)
(when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED))
(set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))
(when (positive? (bitwise-and changed GDK_WINDOW_STATE_FULLSCREEN))
(set! fullscreen? (positive? (bitwise-and value GDK_WINDOW_STATE_FULLSCREEN))))
(when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED))
(set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED)))))
(define/public (iconized?)
is-iconized?)
(define/public (iconize on?)
(if on?
(gtk_window_iconify gtk)
(gtk_window_deiconify gtk)))
(define/public (fullscreened?)
fullscreen?)
(define/public (fullscreen on?)
(if on?
(gtk_window_fullscreen gtk)
(gtk_window_unfullscreen gtk)))
(def/public-unimplemented get-menu-bar)
(define/public (set-title s)
(set! saved-title s)
(gtk_window_set_title gtk (if is-modified?
(string-append s "*")
s)))
(define/public (display-changed) (void))))
;; ----------------------------------------
(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int))
(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int))
(define-gdk gdk_screen_get_monitor_geometry (_fun _GdkScreen _int _GdkRectangle-pointer -> _void))
(define-gdk gdk_screen_get_n_monitors (_fun _GdkScreen -> _int))
(define (monitor-rect num fail)
(let ([s (gdk_screen_get_default)]
[r (make-GdkRectangle 0 0 0 0)])
(unless (num . < . (gdk_screen_get_n_monitors s))
(fail))
(gdk_screen_get_monitor_geometry s num r)
r))
(define (display-origin x y all? num fail)
(let ([r (monitor-rect num fail)])
(set-box! x (->normal (- (GdkRectangle-x r))))
(set-box! y (->normal (- (GdkRectangle-y r))))))
(define (display-size w h all? num fail)
(let ([r (monitor-rect num fail)])
(set-box! w (->normal (GdkRectangle-width r)))
(set-box! h (->normal (GdkRectangle-height r)))))
(define (display-count)
(gdk_screen_get_n_monitors (gdk_screen_get_default)))
(define (display-bitmap-resolution num fail)
(define (get) (* (or (get-interface-scale-factor num)
1.0)
(gdk_screen_get_monitor_scale_factor
(gdk_screen_get_default)
num)))
(if (zero? num)
(get)
(if (num . < . (gdk_screen_get_n_monitors (gdk_screen_get_default)))
(get)
(fail))))
(define (location->window x y)
(for/or ([f (in-hash-keys all-frames)])
(let ([fx (send f get-x)]
[fw (send f get-width)])
(and (<= fx x (+ fx fw))
(let ([fy (send f get-y)]
[fh (send f get-height)])
(<= fy y (+ fy fh)))
f))))
;; ----------------------------------------
(define (get-current-mouse-state)
(define-values (x y mods) (gdk_window_get_pointer
(gdk_screen_get_root_window
(gdk_screen_get_default))))
(define (maybe mask sym)
(if (zero? (bitwise-and mods mask))
null
(list sym)))
(values (make-object point% x y)
(append
(maybe GDK_BUTTON1_MASK 'left)
(maybe GDK_BUTTON2_MASK 'middle)
(maybe GDK_BUTTON3_MASK 'right)
(maybe GDK_SHIFT_MASK 'shift)
(maybe GDK_LOCK_MASK 'caps)
(maybe GDK_CONTROL_MASK 'control)
(maybe GDK_MOD1_MASK 'alt)
(maybe GDK_META_MASK 'meta))))
(define (tell-all-frames-signal-changed n)
(define frames (for/list ([f (in-hash-keys all-frames)]) f))
(for ([f (in-hash-keys all-frames)])
(define e (send f get-eventspace))
(unless (eventspace-shutdown? e)
(parameterize ([current-eventspace e])
(queue-callback
(λ ()
(send f display-changed)))))))
(define-signal-handler
connect-monitor-changed-signal
"monitors-changed"
(_fun _GdkScreen -> _void)
(λ (screen) (tell-all-frames-signal-changed 1)))
(define-signal-handler
connect-screen-changed-signal
"screen-changed"
(_fun _GdkScreen -> _void)
(λ (screen) (tell-all-frames-signal-changed 2)))
(define-signal-handler
connect-composited-changed-signal
"composited-changed"
(_fun _GdkScreen -> _void)
(λ (screen) (tell-all-frames-signal-changed 3)))
(define (screen-size-signal-connect connect-signal)
(void (connect-signal (cast (gdk_screen_get_default) _GdkScreen _GtkWidget))))
(screen-size-signal-connect connect-monitor-changed-signal)
(screen-size-signal-connect connect-screen-changed-signal)
(screen-size-signal-connect connect-composited-changed-signal)
Reference in New Issue View Git Blame Copy Permalink