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

Support and prefer GTK+ 3 on Unix/X

Browse Source 
The main advantage of GTK+ 3 is better support for HiDPI
displays. If GTK+ 3 libraries are not available or if the
`PLT_GTK2` environment variable is defined, GTK+ 2 is used
as before.
This commit is contained in:
Matthew Flatt 2015-08-10 07:06:54 -06:00
parent 204c0b6694
commit f42356da3f
32 changed files with 663 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gui-doc/scribblings/gui/libs.scrbl
View File

@ -7,14 +7,17 @@
See @secref[#:doc draw-doc "libs"] in @other-manual[draw-doc] for
information on platform library dependencies for
@racketmodname[racket/draw]. On Unix, the following additional
system libraries must be installed for @racketmodname[racket/gui/base]:
@racketmodname[racket/draw]. On Unix, GTK+ 3 is used if its libraries
can be found and the @indexed-envvar{PLT_GTK2} environment is not
defined. Otherwise, GTK+ 2 is used. The following additional system
libraries must be installed for @racketmodname[racket/gui/base] in
either case:
@itemlist[
@item{@filepath{libgdk-x11-2.0[.0]}}
@item{@filepath{libgdk_pixbuf-2.0[.0]}}
@item{@filepath{libgtk-x11-2.0[.0]}}
@item{@filepath{libgdk-3.0[.0]} (GTK+ 3) or @filepath{libgdk-x11-2.0[.0]} (GTK+ 2)}
@item{@filepath{libgdk_pixbuf-2.0[.0]} (GTK+ 2)}
@item{@filepath{libgtk-3.0[.0]} (GTK+ 3) or @filepath{libgtk-x11-2.0[.0]} (GTK+ 2)}
@item{@filepath{libgio-2.0[.0]} --- optional, for detecting interface scaling}
@item{@filepath{libGL} --- optional, for OpenGL support}
@item{@filepath{libGL[.1]} --- optional, for OpenGL support}
@item{@filepath{libunique-1.0[.0]} --- optional, for single-instance support}
]

22
gui-doc/scribblings/gui/miscwin-funcs.scrbl
View File

@ -186,6 +186,28 @@ The keymap for the read-eval-print loop's editor is initialized by
@racket[current-text-keymap-initializer] parameter.
}
@defproc[(graphical-system-type) symbol?]{
Returns a symbol indicating the platform native GUI layer on which
@racket[racket/gui] is running. The current possible values are as
follows:
@itemlist[
@item{@racket['win32] (Windows)}
@item{@racket['cocoa] (Mac OS X)}
@item{@racket['gtk2] --- GTK+ version 2}
@item{@racket['gtk3] --- GTK+ version 3}
]
@history[#:added "1.15"]}
@defproc[(textual-read-eval-print-loop) void?]{
Similar to @racket[read-eval-print-loop], except that evaluation uses

4
gui-lib/info.rkt
View File

@ -6,7 +6,7 @@
"data-lib"
"base"
"syntax-color-lib"
("draw-lib" #:version "1.5")
("draw-lib" #:version "1.6")
"snip-lib"
"wxme-lib"
"pict-lib"
@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby))
(define version "1.14")
(define version "1.15")

1
gui-lib/mred/mred-sig.rkt
View File

@ -108,6 +108,7 @@ get-window-text-extent
gl-config%
gl-context<%>
graphical-read-eval-print-loop
graphical-system-type
group-box-panel%
grow-box-spacer-pane%
hide-cursor-until-moved

1
gui-lib/mred/private/mred.rkt
View File

@ -153,6 +153,7 @@
eventspace-shutdown?
eventspace-event-evt
get-panel-background
graphical-system-type
the-editor-wordbreak-map
make-screen-bitmap

3
gui-lib/mred/private/wx/cocoa/platform.rkt
View File

@ -91,4 +91,5 @@
make-gl-bitmap
check-for-break
key-symbol-to-menu-key
needs-grow-box-spacer?))
needs-grow-box-spacer?
graphical-system-type))

5
gui-lib/mred/private/wx/cocoa/procs.rkt
View File

@ -66,7 +66,8 @@
file-selector
key-symbol-to-menu-key
needs-grow-box-spacer?
get-current-mouse-state)
get-current-mouse-state
graphical-system-type)
(import-class NSScreen NSCursor NSMenu NSEvent)
@ -198,6 +199,8 @@
(define (needs-grow-box-spacer?)
(not (version-10.7-or-later?)))
(define (graphical-system-type) 'cocoa)
;; ------------------------------------------------------------
;; Mouse and modifier-key state

5
gui-lib/mred/private/wx/common/backing-dc.rkt
View File

@ -204,11 +204,13 @@
(define cr #f)
(define w 0)
(define h 0)
(define mx (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0))
(super-new)
(define/public (set-cr new-cr new-w new-h)
(set! cr new-cr)
(when cr (cairo_get_matrix cr mx))
(set! w new-w)
(set! h new-h)
(when cr
@ -216,6 +218,9 @@
(define/override (get-cr) cr)
(define/override (init-cr-matrix cr)
(cairo_set_matrix cr mx))
(define/override (reset-clip cr)
(super reset-clip cr)
(cairo_rectangle cr 0 0 w h)

3
gui-lib/mred/private/wx/gtk/button.rkt
View File

@ -97,8 +97,7 @@
(define both-labels? (pair? label))
(when (eq? event-type 'button)
(set-gtk-object-flags! gtk (bitwise-ior (get-gtk-object-flags gtk)
GTK_CAN_DEFAULT)))
(gtk_widget_set_can_default gtk #t))
(set-auto-size)

179
gui-lib/mred/private/wx/gtk/canvas.rkt
View File

@ -1,11 +1,13 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
racket/class
racket/draw
ffi/unsafe/alloc
(except-in racket/draw/private/color
color% make-color)
racket/draw/private/local
racket/draw/unsafe/cairo
"../common/backing-dc.rkt"
"../common/canvas-mixin.rkt"
"../../syntax.rkt"
@ -20,7 +22,6 @@
"dc.rkt"
"gl-context.rkt"
"combo.rkt"
"pixbuf.rkt"
"gcwin.rkt"
"panel.rkt")
@ -41,14 +42,29 @@
(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_combo_box_remove_text (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_text_new (_fun -> _GtkWidget)
#:make-fail make-not-available)
(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)
#:fail (lambda () gtk_combo_box_text_new))
(define-gtk gtk_combo_box_text_append_text (_fun _GtkWidget _string -> _void)
#:make-fail make-not-available)
(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)
#:fail (lambda () gtk_combo_box_text_append_text))
(define-gtk gtk_combo_box_text_remove (_fun _GtkWidget _int -> _void)
#:make-fail make-not-available)
(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)
#:fail (lambda () gtk_combo_box_text_remove))
(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void))
(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))
(define-gtk gtk_fixed_set_has_window (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_widget_set_has_window (_fun _GtkWidget _gboolean -> _void)
#:make-fail make-not-available)
(define-gtk gtk_fixed_set_has_window (_fun _GtkWidget _gboolean -> _void)
#:fail (lambda () gtk_widget_set_has_window))
(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget))
(define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget))
@ -184,7 +200,7 @@
(let ([wx (gtk->wx gtk)])
(if wx
(begin
(unless (send wx paint-or-queue-paint)
(unless (send wx paint-or-queue-paint #f)
(let ([gc (send wx get-canvas-background-for-clearing)])
(when gc
(gdk_draw_rectangle (widget-window gtk) gc #t
@ -193,6 +209,33 @@
(not (send wx is-panel?)))
#f))))
(define-gdk gdk_window_get_background_pattern (_fun _GdkWindow -> (_or-null _cairo_pattern_t)))
(define-gdk gdk_window_get_effective_parent (_fun _GdkWindow -> _GdkWindow))
(define-signal-handler connect-draw "draw"
(_fun _GtkWidget _cairo_t -> _gboolean)
(lambda (gtk cr)
(let ([wx (gtk->wx gtk)])
(if wx
(let ([col (send wx get-canvas-background-for-backing)]
[win (widget-window gtk)])
(when (and win (not col))
;; Before transparent drawing, we need to install the
;; parent window's pattern.
(cairo_set_source cr (gdk_window_get_background_pattern
(gdk_window_get_effective_parent win)))
(cairo_rectangle cr 0 0 32000 32000)
(cairo_fill cr))
(unless (send wx paint-or-queue-paint cr)
(when col
(cairo_set_source_rgb cr
(color-red col)
(color-green col)
(color-blue col))
(cairo_rectangle cr 0 0 32000 32000)
(cairo_fill cr)))
(not (send wx is-panel?)))
#f))))
(define-signal-handler connect-value-changed-h "value-changed"
(_fun _GtkWidget -> _void)
(lambda (gtk)
@ -244,7 +287,8 @@
refresh-for-autoscroll refresh-all-children
reset-auto-scroll
get-eventspace
register-extra-gtk)
register-extra-gtk
call-pre-on-event set-focus on-event)
(define is-combo? (memq 'combo style))
(define has-border? (or (memq 'border style)
@ -252,7 +296,9 @@
(define margin (if has-border? 1 0))
(define-values (client-gtk container-gtk gtk
(define flush-win-box (mcons #f 0))
(define-values (client-gtk container-gtk gtk
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
combo-button-gtk
scroll-width)
@ -274,7 +320,11 @@
(memq 'auto-hscroll style))]
[vs? (or (memq 'vscroll style)
(memq 'auto-vscroll style))])
(let ([h (as-gtk-allocation (gtk_hbox_new #f 0))]
(let ([border (and has-border?
(as-gtk-allocation (gtk_hbox_new #f 0)))]
[h (if has-border?
(gtk_hbox_new #f 0)
(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)]
@ -292,7 +342,8 @@
(gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping
(when has-border?
(gtk_container_set_border_width h margin)
(connect-expose-border h))
(connect-expose/draw-border border h))
(when border (gtk_box_pack_start border h #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 h v2 #f #f 0)
@ -303,7 +354,8 @@
(when hs?
(gtk_widget_show hscroll))
(gtk_widget_show vscroll)
(gtk_widget_show h)
(when border
(gtk_widget_show h))
(gtk_widget_show v)
(when vs?
(gtk_widget_show v2))
@ -316,7 +368,7 @@
(gtk_widget_show container-gtk))
(let ([req (make-GtkRequisition 0 0)])
(gtk_widget_size_request vscroll req)
(values client-gtk container-gtk h hadj vadj
(values client-gtk container-gtk (or border h) hadj vadj
(and hs? h2)
(and vs? v2)
(and hs? vs? resize-box)
@ -329,12 +381,15 @@
(values orig-entry gtk 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))])
[h (gtk_hbox_new #f 0)]
[border (as-gtk-allocation (gtk_hbox_new #f 0))])
(gtk_box_pack_start border h #t #t 0)
(gtk_box_pack_start h client-gtk #t #t 0)
(gtk_container_set_border_width h margin)
(connect-expose-border h)
(connect-expose/draw-border border h)
(gtk_widget_show h)
(gtk_widget_show client-gtk)
(values client-gtk client-gtk h #f #f #f #f #f #f 0))]
(values client-gtk client-gtk border #f #f #f #f #f #f 0))]
[else
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
(values client-gtk client-gtk client-gtk #f #f #f #f #f #f 0))])))
@ -387,7 +442,9 @@
(GtkRequisition-height r)
(GtkRequisition-height r))))
(connect-expose client-gtk)
(if gtk3?
(connect-draw client-gtk)
(connect-expose client-gtk))
#;(gtk_widget_set_double_buffered client-gtk #f)
(connect-key-and-mouse client-gtk)
(connect-focus client-gtk)
@ -401,8 +458,7 @@
GDK_LEAVE_NOTIFY_MASK))
(unless (or (memq 'no-focus style)
(is-panel?))
(set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk)
GTK_CAN_FOCUS)))
(gtk_widget_set_can_focus client-gtk #t))
(check-combo)
(when combo-button-gtk
(connect-combo-key-and-mouse combo-button-gtk))
@ -412,6 +468,20 @@
(when hscroll-adj (connect-value-changed-h hscroll-adj))
(when vscroll-adj (connect-value-changed-v vscroll-adj))
(when (and gtk3? (or hscroll-gtk vscroll-gtk))
;; Need to get scroll size now that the control is shown
(let ([req (make-GtkRequisition 0 0)])
(gtk_widget_show gtk)
(gtk_widget_get_preferred_size (or vscroll-gtk hscroll-gtk) req #f)
(set! scroll-width (if vscroll-gtk
(GtkRequisition-width req)
(GtkRequisition-height req)))
(gtk_widget_hide gtk)))
(when (and gtk3? is-combo?)
;; Needed for sizing:
(gtk_combo_box_append_text gtk (make-string 10 #\X)))
(set-auto-size)
(adjust-client-delta (+ (* 2 margin)
(if (or (memq 'vscroll style)
@ -423,6 +493,9 @@
(memq 'auto-hscroll style))
scroll-width
0)))
(when (and gtk3? is-combo?)
(infer-client-delta #:inside client-gtk)
(gtk_combo_box_text_remove gtk 0))
(define/public (is-panel?) #f)
@ -447,11 +520,19 @@
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
(define/override (internal-pre-on-event gtk e)
(if (and (ptr-equal? gtk combo-button-gtk)
(send e button-down?))
(begin
(on-popup)
#t)
(if (ptr-equal? gtk combo-button-gtk)
(cond
[gtk3?
(queue-window-event this (lambda ()
(unless (call-pre-on-event this e)
(when (send e button-down?)
(set-focus))
(on-event e))))
#t]
[(send e button-down?)
(on-popup)
#t]
[else #f])
#f))
(define/public (popup-combo)
;; Unfortunately, the user has to hold the mouse
@ -475,11 +556,11 @@
(queue-window-refresh-event this thunk))
(define/public (skip-pre-paint?) #f)
(define/public (paint-or-queue-paint)
(define/public (paint-or-queue-paint cr)
;; in atomic mode
(if for-gl?
(queue-paint)
(or (do-canvas-backing-flush #f)
(or (do-canvas-backing-flush cr)
(begin
(queue-paint)
#f))))
@ -487,18 +568,18 @@
;; overridden to extend for scheduled periodic flushes:
(define/public (schedule-periodic-backing-flush)
(void))
(define/public (do-canvas-backing-flush ctx)
(do-backing-flush this dc (if is-combo?
(get-subwindow client-gtk)
(widget-window client-gtk))))
(define/public (do-canvas-backing-flush cr)
(do-backing-flush this dc (if gtk3?
cr
(if is-combo?
(get-subwindow client-gtk)
(widget-window client-gtk)))))
(define/public (on-paint) (void))
(define flush-win-box (mcons #f 0))
(define/public (get-flush-window)
(atomically
(if (zero? (bitwise-and (get-gtk-object-flags client-gtk)
GTK_MAPPED))
(if (not (gtk_widget_get_mapped client-gtk))
(mcons #f #f)
(if (win-box-valid? flush-win-box)
flush-win-box
@ -570,8 +651,9 @@
[(and v? (not h?))
;; remove corner
(gtk_widget_hide resize-box)]))
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
(+ (* 2 margin) (if h? scroll-width 0))))
(unless is-combo?
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
(+ (* 2 margin) (if h? scroll-width 0)))))
(define suspend-scroll-callbacks? #f)
(define/public (deliver-scroll-callbacks?) (not suspend-scroll-callbacks?))
@ -653,7 +735,7 @@
(->long (dispatch which gtk_adjustment_get_value 0))))
(define clear-bg?
(and (not (memq 'transparent style))
(and (not (memq 'transparent style))
(not (memq 'no-autoclear style))))
(define transparent?
(memq 'transparent style))
@ -678,7 +760,7 @@
#f))
(when is-combo?
(connect-changed client-gtk))
(connect-changed (if gtk3? gtk client-gtk)))
(define combo-count 0)
(define/public (clear-combo-items)
@ -786,30 +868,29 @@
(define reg-blits null)
(define/private (register-one-blit x y w h on-pixbuf off-pixbuf)
(let* ([cwin (widget-window client-gtk)])
(atomically
(let ([win (create-gc-window cwin x y w h)])
(let ([r (scheme_add_gc_callback
(make-gc-show-desc win on-pixbuf w h)
(make-gc-hide-desc win off-pixbuf w h))])
(cons win r))))))
(define/private (register-one-blit x y w h on-gc-bitmap off-gc-bitmap)
(atomically
(let ([win (create-gc-window client-gtk x y w h)])
(let ([r (scheme_add_gc_callback
(make-gc-show-desc win on-gc-bitmap w h)
(make-gc-hide-desc win off-gc-bitmap w h))])
(cons win r)))))
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
(let ([on (fix-bitmap-size on w h on-x on-y)]
[off (fix-bitmap-size off w h off-x off-y)])
(let ([on-pixbuf (bitmap->pixbuf on (->screen 1.0))]
[off-pixbuf (bitmap->pixbuf off (->screen 1.0))])
(let ([on-gc-bitmap (bitmap->gc-bitmap on client-gtk)]
[off-gc-bitmap (bitmap->gc-bitmap off client-gtk)])
(atomically
(set! reg-blits (cons (register-one-blit (->screen x) (->screen y)
(->screen w) (->screen h)
on-pixbuf off-pixbuf)
on-gc-bitmap off-gc-bitmap)
reg-blits))))))
(define/public (unregister-collecting-blits)
(atomically
(for ([r (in-list reg-blits)])
(g_object_unref (car r))
(free-gc-window (car r))
(scheme_remove_gc_callback (cdr r)))
(set! reg-blits null))))))

19
gui-lib/mred/private/wx/gtk/choice.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
racket/class
"../../syntax.rkt"
"../../lock.rkt"
@ -16,9 +17,21 @@
;; ----------------------------------------
(define-gtk gtk_combo_box_new_text (_fun -> _GtkWidget))
(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void))
(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_text_new (_fun -> _GtkWidget)
#:make-fail make-not-available)
(define-gtk gtk_combo_box_new_text (_fun -> _GtkWidget)
#:fail (lambda () gtk_combo_box_text_new))
(define-gtk gtk_combo_box_text_append_text (_fun _GtkWidget _string -> _void)
#:make-fail make-not-available)
(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)
#:fail (lambda () gtk_combo_box_text_append_text))
(define-gtk gtk_combo_box_text_remove (_fun _GtkWidget _int -> _void)
#:make-fail make-not-available)
(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)
#:fail (lambda () gtk_combo_box_text_remove))
(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))

13
gui-lib/mred/private/wx/gtk/clipboard.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require racket/class
racket/promise
ffi/unsafe
ffi/unsafe/alloc
racket/draw/unsafe/bstr
@ -18,7 +19,7 @@
_GtkSelectionData
gtk_selection_data_get_length
gtk_selection_data_get_data
primary-atom
get-primary-atom
get-selection-eventspace))
(define (has-x-selection?) #t)
@ -72,8 +73,10 @@
(define clear_owner
(function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void)))
(define primary-atom (gdk_atom_intern "PRIMARY" #t))
(define clipboard-atom (gdk_atom_intern "CLIPBOARD" #t))
(define primary-atom (delay (gdk_atom_intern "PRIMARY" #t)))
(define clipboard-atom (delay (gdk_atom_intern "CLIPBOARD" #t)))
(define (get-primary-atom) (force primary-atom))
(define the-x-selection-driver #f)
@ -145,8 +148,8 @@
(define cb (gtk_clipboard_get
(if x-selection?
primary-atom
clipboard-atom)))
(force primary-atom)
(force clipboard-atom))))
(define self-box #f)
(define/public (get-client) client)

12
gui-lib/mred/private/wx/gtk/combo.rkt
View File

@ -4,6 +4,7 @@
"../../syntax.rkt"
"types.rkt"
"utils.rkt"
"const.rkt"
"window.rkt")
;; Hacks for working with GtkComboBox[Entry]
@ -144,4 +145,13 @@
hand-id))))])
(connect-key-and-mouse button-gtk (and hand-id #t))
(when hand-id
(connect-reorder-button-press button-gtk (cast hand-id _long _pointer)))))
(connect-reorder-button-press button-gtk (cast hand-id _long _pointer)))
(when gtk3?
(gtk_widget_add_events button-gtk (bitwise-ior GDK_KEY_PRESS_MASK
GDK_KEY_RELEASE_MASK
GDK_BUTTON_PRESS_MASK
GDK_BUTTON_RELEASE_MASK
GDK_POINTER_MOTION_MASK
GDK_FOCUS_CHANGE_MASK
GDK_ENTER_NOTIFY_MASK
GDK_LEAVE_NOTIFY_MASK)))))

62
gui-lib/mred/private/wx/gtk/dc.rkt
View File

@ -1,9 +1,11 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
racket/class
"utils.rkt"
"types.rkt"
"window.rkt"
"frame.rkt"
"x11.rkt"
"win32.rkt"
"gl-context.rkt"
@ -23,17 +25,24 @@
gdk_gc_new
gdk_gc_unref
gdk_gc_set_rgb_fg_color
gdk_gc_set_line_attributes
gdk_draw_rectangle))
(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t)
#:wrap (allocator cairo_destroy))
(define-gdk gdk_gc_unref (_fun _pointer -> _void)
#:wrap (deallocator))
#:wrap (deallocator)
#:make-fail make-not-available)
(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer)
#:wrap (allocator gdk_gc_unref))
(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))
#:wrap (allocator gdk_gc_unref)
#:make-fail make-not-available)
(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void)
#:make-fail make-not-available)
(define-gdk gdk_gc_set_line_attributes (_fun _pointer _int _int _int _int -> _void)
#:make-fail make-not-available)
(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void)
#:make-fail make-not-available)
(define-cstruct _GdkVisual-rec ([type-instance _pointer]
[ref_count _uint]
@ -42,18 +51,20 @@
[depth _int]))
(define-gdk gdk_visual_get_system (_fun -> _GdkVisual-rec-pointer))
(define x11-bitmap%
(define x11-bitmap%/gtk2
(class bitmap%
(init w h gdk-win)
(init w h gtk)
(super-make-object (make-alternate-bitmap-kind w h (->screen 1.0)))
(define pixmap (gdk_pixmap_new gdk-win
(min (max 1 (->screen w)) 32000)
(min (max 1 (->screen h)) 32000)
(if gdk-win
-1
(GdkVisual-rec-depth
(gdk_visual_get_system)))))
(define pixmap
(let ([gdk-win (and gtk (widget-window gtk))])
(gdk_pixmap_new gdk-win
(min (max 1 (->screen w)) 32000)
(min (max 1 (->screen h)) 32000)
(if gdk-win
-1
(GdkVisual-rec-depth
(gdk_visual_get_system))))))
(define s
(cairo_xlib_surface_create (gdk_x11_display_get_xdisplay
(gdk_drawable_get_display pixmap))
@ -89,6 +100,18 @@
(gobject-unref pixmap)
(set! s #f)))))
(define x11-bitmap%/gtk3
(class bitmap%
(init w h gtk)
(super-make-object w h #f #t (if gtk
(->screen (gtk_widget_get_scale_factor gtk))
(display-bitmap-resolution 0 (lambda () 1.0))))))
(define x11-bitmap%
(if gtk3?
x11-bitmap%/gtk3
x11-bitmap%/gtk2))
(define win32-bitmap%
(class bitmap%
(init w h gdk-win)
@ -134,8 +157,8 @@
(define/override (make-backing-bitmap w h)
(cond
[(and (eq? 'unix (system-type))
(send canvas get-canvas-background))
(make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk)))]
(or gtk3? (send canvas get-canvas-background)))
(make-object x11-bitmap% w h (send canvas get-client-gtk))]
[(and (eq? 'windows (system-type))
(send canvas get-canvas-background))
(make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))]
@ -165,13 +188,16 @@
(define/override (cancel-delay req)
(cancel-flush-delay req))))
(define (do-backing-flush canvas dc win)
(define (do-backing-flush canvas dc win-or-cr)
(send dc on-backing-flush
(lambda (bm)
(let ([w (box 0)]
[h (box 0)])
(send canvas get-client-size w h)
(let ([cr (gdk_cairo_create win)])
(let ([cr (if gtk3?
win-or-cr
(gdk_cairo_create win-or-cr))])
(cairo_scale cr (->screen 1.0) (->screen 1.0))
(backing-draw-bm bm cr (unbox w) (unbox h) 0 0 (->screen 1.0))
(cairo_destroy cr))))))
(unless gtk3?
(cairo_destroy cr)))))))

34
gui-lib/mred/private/wx/gtk/frame.rkt
View File

@ -48,7 +48,9 @@
(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_widget_set_uposition (_fun _GtkWidget _int _int -> _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)))
@ -62,6 +64,8 @@
(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))
@ -85,6 +89,8 @@
[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)
@ -173,22 +179,24 @@
(when floating?
(gtk_window_set_keep_above gtk #t)
(gtk_window_set_focus_on_map gtk #f))
(define-values (vbox-gtk panel-gtk)
(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 panel-gtk #t #t 0)
(values vbox-gtk panel-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:
(set-gtk-object-flags! panel-gtk
(bitwise-ior (get-gtk-object-flags panel-gtk)
GTK_CAN_FOCUS))
(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)
@ -235,7 +243,7 @@
(define/public (set-menu-bar mb)
(let ([mb-gtk (send mb get-gtk)])
(gtk_box_pack_start vbox-gtk mb-gtk #t #t 0)
(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
@ -444,8 +452,7 @@
(let ([f-gtk (gtk_window_get_focus gtk)])
(and f-gtk
(or even-if-not-active?
(positive? (bitwise-and (get-gtk-object-flags f-gtk)
GTK_HAS_FOCUS)))
(gtk_widget_has_focus f-gtk))
(gtk->wx f-gtk))))
(define/override (call-pre-on-event w e)
@ -576,8 +583,11 @@
(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))
(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)))

12
gui-lib/mred/private/wx/gtk/gauge.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
racket/class
"../../syntax.rkt"
"item.rkt"
@ -15,9 +16,18 @@
(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 gtk_orientable_set_orientation (_fun _GtkWidget _int -> _void)
#:make-fail make-not-available)
(define-gtk gtk_progress_bar_set_inverted (_fun _GtkWidget _gboolean -> _void)
#:make-fail make-not-available)
(define-gtk gtk_progress_bar_set_orientation (_fun _GtkWidget _int -> _void)
#:fail (lambda ()
(lambda (w o)
(gtk_orientable_set_orientation w GTK_ORIENTATION_VERTICAL)
(gtk_progress_bar_set_inverted w #t))))
(define GTK_PROGRESS_BOTTOM_TO_TOP 2)
(define GTK_ORIENTATION_VERTICAL 1)
(defclass gauge% item%
(init parent

158
gui-lib/mred/private/wx/gtk/gcwin.rkt
View File

@ -1,16 +1,24 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
racket/draw/unsafe/cairo
racket/class
"utils.rkt"
"types.rkt"
"window.rkt")
"window.rkt"
"pixbuf.rkt"
"x11.rkt")
(provide
(protect-out scheme_add_gc_callback
scheme_remove_gc_callback
create-gc-window
free-gc-window
make-gc-show-desc
make-gc-hide-desc))
make-gc-hide-desc
bitmap->gc-bitmap))
;; Gtk2, only:
(define-cstruct _GdkWindowAttr
([title _string]
[event_mask _int]
@ -20,7 +28,7 @@
[height _int]
[wclass _int] ; GDK_INPUT_OUTPUT
[visual _pointer]
[colormap _pointer]
[colormap _pointer] ; this field is absent in Gtk3
[window_type _int] ; GDK_WINDOW_CHILD
[cursor _pointer]
[wmclass_name _string]
@ -44,52 +52,136 @@
(define GDK_WINDOW_CHILD 2)
(define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint
-> _GdkWindow))
(define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint -> _GdkWindow))
(define-gdk gdk_window_show _fpointer)
(define-gdk gdk_window_hide _fpointer)
(define-gdk gdk_display_flush _fpointer)
(define-gdk gdk_draw_pixbuf _fpointer)
;; Gtk2
(define-gdk gdk_draw_pixbuf _fpointer
#:make-fail make-not-available)
(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
(define-mz scheme_remove_gc_callback (_fun _racket -> _void))
(define (create-gc-window cwin x y w h)
(let ([win (gdk_window_new cwin (make-GdkWindowAttr
""
0
x y w h
GDK_INPUT_OUTPUT
#f #f
GDK_WINDOW_CHILD
#f
"" "" #f 0)
(bitwise-ior GDK_WA_X
GDK_WA_Y))])
win))
(define-x11 XSetWindowBackgroundPixmap _fpointer #:fail (lambda () #f))
(define-x11 XMapRaised _fpointer #:fail (lambda () #f))
(define-x11 XUnmapWindow _fpointer #:fail (lambda () #f))
(define (make-draw win pixbuf w h)
(vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void
gdk_draw_pixbuf
win #f pixbuf
0 0 0 0 w h
0 0 0))
(define _GdkVisual (_cpointer 'GdkVisual))
(define-gdk gdk_window_get_visual (_fun _GdkWindow -> _GdkVisual))
(define-gdk gdk_visual_get_depth (_fun _GdkVisual -> _int))
(define (bitmap->gc-bitmap bm client-gtk)
(cond
[gtk3?
; Generate an X11 Pixmap
(define gwin (widget-window client-gtk))
(define display (gdk_x11_display_get_xdisplay (gdk_window_get_display gwin)))
(define sf (->screen (gtk_widget_get_scale_factor client-gtk)))
(define w (send bm get-width))
(define h (send bm get-height))
(define bms (send bm get-backing-scale))
(define cw (inexact->exact (ceiling (* sf w))))
(define ch (inexact->exact (ceiling (* sf h))))
(define visual (gdk_window_get_visual gwin))
(define pixmap (XCreatePixmap display
(gdk_x11_window_get_xid gwin)
cw ch
(gdk_visual_get_depth visual)))
(define s (cairo_xlib_surface_create display
(cast pixmap _pointer _ulong)
(gdk_x11_visual_get_xvisual visual)
cw ch))
(define cr (cairo_create s))
(define pat (cairo_pattern_create_for_surface (send bm get-handle)))
(cairo_pattern_set_matrix pat (make-cairo_matrix_t (/ bms sf) 0.0
0.0 (/ bms sf)
0.0 0.0))
(cairo_set_source cr pat)
(cairo_pattern_destroy pat)
(cairo_rectangle cr 0 0 cw ch)
(cairo_fill cr)
(cairo_destroy cr)
(cairo_surface_destroy s)
pixmap]
[else
;; Generate a Gdk Pixbuf
(bitmap->pixbuf bm (->screen 1.0))]))
(define (create-gc-window client-gtk x y w h)
(define cwin (widget-window client-gtk))
(cond
[gtk3?
;; Work at the level of X11 to change the screen without an event loop
(define display (gdk_x11_display_get_xdisplay (gdk_window_get_display cwin)))
(define s (gtk_widget_get_scale_factor client-gtk))
(cons display
(XCreateSimpleWindow display
(gdk_x11_window_get_xid cwin)
(* s x) (* s y) (* s w) (* s h) 0 0 0))]
[else
(as-gtk-window-allocation
(gdk_window_new cwin (make-GdkWindowAttr
""
0
x y w h
GDK_INPUT_OUTPUT
#f #f
GDK_WINDOW_CHILD
#f
"" "" #f 0)
(bitwise-ior GDK_WA_X
GDK_WA_Y)))]))
(define (free-gc-window win)
(cond
[gtk3? (XDestroyWindow (car win) (cdr win))]
[else (g_object_unref win)]))
(define (make-draw win gc-bitmap w h)
(cond
[gtk3? (vector 'ptr_ptr_ptr->void
XSetWindowBackgroundPixmap
(car win)
(cdr win)
gc-bitmap)]
[else (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void
gdk_draw_pixbuf
win #f gc-bitmap
0 0 0 0 w h
0 0 0)]))
(define (make-flush)
(vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f))
(define (make-gc-show-desc win pixbuf w h)
(vector
(vector 'ptr_ptr_ptr->void gdk_window_show win #f #f)
(make-draw win pixbuf w h)
(make-flush)))
(define (make-gc-show-desc win gc-bitmap w h)
(cond
[gtk3? (vector
(make-draw win gc-bitmap w h)
(vector 'ptr_ptr_ptr->void
XMapRaised
(car win)
(cdr win)
#f)
(make-flush))]
[else (vector
(vector 'ptr_ptr_ptr->void gdk_window_show win #f #f)
(make-draw win gc-bitmap w h)
(make-flush))]))
(define (make-gc-hide-desc win pixbuf w h)
(define (make-gc-hide-desc win gc-bitmap w h)
(vector
;; draw the ``off'' bitmap so we can flush immediately
(make-draw win pixbuf w h)
(make-draw win gc-bitmap w h)
(make-flush)
;; hide the window; it may take a while for the underlying canvas
;; to refresh:
(vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f)))
(if gtk3?
(vector 'ptr_ptr_ptr->void
XUnmapWindow
(car win)
(cast (cdr win) _Window _pointer)
#f)
(vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f))))

10
gui-lib/mred/private/wx/gtk/gl-context.rkt
View File

@ -32,12 +32,8 @@
;; ===================================================================================================
;; X11/GLX FFI
(define x-lib (ffi-lib/complaint-on-failure "libX11" '("")))
(define gl-lib (ffi-lib/complaint-on-failure "libGL" '("1" "")))
(define-ffi-definer define-x x-lib
#:default-make-fail make-not-available)
(define-ffi-definer define-glx gl-lib
#:default-make-fail make-not-available)
@ -81,14 +77,14 @@
(define GLX_CONTEXT_CORE_PROFILE_BIT_ARB #x1)
(define GLX_CONTEXT_COMPATIBILITY_PROFILE_BIT_ARB #x2)
(define-x XFree (_fun _pointer -> _int)
(define-x11 XFree (_fun _pointer -> _int)
#:wrap (deallocator))
(define-x XSetErrorHandler
(define-x11 XSetErrorHandler
(_fun (_fun _Display _XErrorEvent -> _int)
-> (_fun _Display _XErrorEvent -> _int)))
(define-x XSync
(define-x11 XSync
(_fun _Display _int -> _void))
(define-glx glXQueryVersion

16
gui-lib/mred/private/wx/gtk/gtk3.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket/base
(require ffi/unsafe)
(provide gtk3?
get-gdk3-lib
get-gtk3-lib)
(define (get-gdk3-lib)
(ffi-lib "libgdk-3" '("0" "")))
(define (get-gtk3-lib)
(ffi-lib "libgtk-3" '("0" "")))
(define gtk3?
(and (not (getenv "PLT_GTK2"))
(get-gdk3-lib)
(get-gtk3-lib)))

25
gui-lib/mred/private/wx/gtk/item.rkt
View File

@ -1,7 +1,11 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
racket/class
racket/draw/private/local
(only-in racket/draw/unsafe/pango
pango_cairo_font_map_get_resolution
pango_cairo_font_map_get_default)
(only-in racket/draw make-font)
"../../syntax.rkt"
"window.rkt"
@ -13,14 +17,27 @@
install-control-font))
(define _PangoFontDescription _pointer)
(define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void))
(define-gtk gtk_widget_override_font (_fun _GtkWidget _PangoFontDescription -> _void)
#:make-fail make-not-available)
(define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void)
#:fail (lambda () gtk_widget_override_font))
(define (install-control-font gtk font)
(when font
(let* ([s (->screen 1)]
[font (if (= s 1)
(let* ([target-size
(cond
[gtk3?
;; Gtk3 ignores the "size-in-pixels" part of a
;; font spec, so we have to adjust the text size
;; to compensate.
(* (send font get-size)
(/ 72.0
(pango_cairo_font_map_get_resolution
(pango_cairo_font_map_get_default))))]
[else (->screen (send font get-size))])]
[font (if (= target-size (send font get-size))
font
(make-font #:size (->screen (send font get-size))
(make-font #:size target-size
#:face (send font get-face)
#:family (send font get-family)
#:style (send font get-style)

5
gui-lib/mred/private/wx/gtk/menu-bar.rkt
View File

@ -24,7 +24,8 @@
(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
(define-gtk gtk_widget_set_usize (_fun _GtkWidget _int _int -> _void))
(define-gtk gtk_widget_set_usize (_fun _GtkWidget _int _int -> _void)
#:fail (lambda () gtk_widget_set_size_request))
(define-gtk ubuntu_menu_proxy_get _fpointer
#:fail (lambda () #f))
@ -101,7 +102,7 @@
(fix-menu-height))
(define/public (reset-menu-height)
(when top-wx
(when (and (not gtk3?) top-wx)
(send top-wx reset-menu-height (fix-menu-height))))
(define/private (fix-menu-height)

32
gui-lib/mred/private/wx/gtk/panel.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/define
racket/draw/unsafe/cairo
"../../syntax.rkt"
"../../lock.rkt"
"window.rkt"
@ -18,7 +20,7 @@
gtk_fixed_move
gtk_container_set_border_width
connect-expose-border))
connect-expose/draw-border))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_event_box_new (_fun -> _GtkWidget))
@ -35,12 +37,14 @@
[gray #x8000])
(when gc
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray))
(unless (= 1 (->screen 1))
(gdk_gc_set_line_attributes gc (->screen 1) 0 0 0))
(let* ([a (widget-allocation gtk)]
[w (sub1 (GtkAllocation-width a))]
[h (sub1 (GtkAllocation-height a))])
(let loop ([gtk gtk] [x 0] [y 0] [can-super? #t])
(if (and can-super?
(not (zero? (bitwise-and (get-gtk-object-flags gtk) GTK_NO_WINDOW))))
(not (gtk_widget_get_has_window gtk)))
;; no window:
(let ([a (widget-allocation gtk)])
(loop (widget-parent gtk) (+ x (GtkAllocation-x a)) (+ y (GtkAllocation-y a))
@ -52,6 +56,28 @@
(gdk_gc_unref gc)))
#f))
(define-gtk gtk_widget_get_allocated_width (_fun _GtkWidget -> _int)
#:make-fail make-not-available)
(define-gtk gtk_widget_get_allocated_height (_fun _GtkWidget -> _int)
#:make-fail make-not-available)
(define-signal-handler connect-draw-border "draw"
(_fun _GtkWidget _cairo_t -> _gboolean)
(lambda (gtk cr)
(cairo_set_source_rgba cr 0.5 0.5 0.5 1.0)
(cairo_set_line_width cr 1.0)
(cairo_rectangle cr
0.5 0.5
(- (gtk_widget_get_allocated_width gtk) 1)
(- (gtk_widget_get_allocated_height gtk) 1))
(cairo_stroke cr)
#f))
(define (connect-expose/draw-border gtk border-gtk)
(if gtk3?
(connect-draw-border gtk #:after? #t)
(connect-expose-border border-gtk)))
(define (panel-mixin %)
(class %
@ -121,7 +147,7 @@
(let ([border-gtk (gtk_fixed_new)])
(gtk_container_add gtk border-gtk)
(gtk_container_set_border_width border-gtk 1)
(connect-expose-border border-gtk)
(connect-expose/draw-border gtk border-gtk)
(gtk_widget_show border-gtk)
border-gtk))))
(define client-gtk (atomically

3
gui-lib/mred/private/wx/gtk/platform.rkt
View File

@ -92,4 +92,5 @@
make-gl-bitmap
check-for-break
key-symbol-to-menu-key
needs-grow-box-spacer?))
needs-grow-box-spacer?
graphical-system-type))

8
gui-lib/mred/private/wx/gtk/procs.rkt
View File

@ -60,7 +60,8 @@
fill-private-color
get-color-from-user
key-symbol-to-menu-key
needs-grow-box-spacer?)
needs-grow-box-spacer?
graphical-system-type)
(define (find-graphical-system-path what)
(case what
@ -159,3 +160,8 @@
(define (check-for-break) #f)
(define (needs-grow-box-spacer?) #f)
(define (graphical-system-type)
(cond
[gtk3? 'gtk3]
[else 'gtk2]))

2
gui-lib/mred/private/wx/gtk/queue.rkt
View File

@ -187,7 +187,7 @@
(and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST)
(let ([s (cast evt _pointer _GdkEventSelection-pointer)])
(= (GdkEventSelection-selection s)
primary-atom))
(get-primary-atom)))
(get-selection-eventspace)))
=> (lambda (e)
(let ([evt (gdk_event_copy evt)])

15
gui-lib/mred/private/wx/gtk/resolution.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base
(require racket/promise
ffi/unsafe
"gsettings.rkt")
"gsettings.rkt"
"gtk3.rkt")
(provide get-interface-scale-factor)
@ -38,11 +39,17 @@
(with-handlers ([exn:fail? (lambda (exn) #f)])
(define gs (force interface-settings))
(define v
(* (g_variant_get_uint32
(g_settings_get_value gs "scaling-factor"))
(* (if gtk3?
;; For Gtk3, toolbox handles this scaling:
1
;; For Gtk2, we can handle explicit settings,
;; but we don't try to infer a scale if the
;; setting is 0:
(max 1
(g_variant_get_uint32
(g_settings_get_value gs "scaling-factor"))))
(g_variant_get_double
(g_settings_get_value gs "text-scaling-factor"))))
(g_object_unref gs)
(and (rational? v)
(positive? v)
v)))

6
gui-lib/mred/private/wx/gtk/tab-panel.rkt
View File

@ -26,8 +26,10 @@
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_widget_ref (_fun _GtkWidget -> _void))
(define-gtk gtk_widget_unref (_fun _GtkWidget -> _void))
(define-gtk gtk_widget_ref (_fun _GtkWidget -> _void)
#:fail (lambda () g_object_ref))
(define-gtk gtk_widget_unref (_fun _GtkWidget -> _void)
#:fail (lambda () g_object_unref))
(define-struct page (bin-gtk label-gtk))

30
gui-lib/mred/private/wx/gtk/utils.rkt
View File

@ -6,11 +6,13 @@
racket/string
racket/draw/unsafe/glib
(only-in '#%foreign ctype-c->scheme)
"gtk3.rkt"
"../common/utils.rkt"
"types.rkt"
"resolution.rkt")
(provide
(provide
gtk3?
define-mz
define-gobj
define-glib
@ -58,24 +60,30 @@
(define gdk-lib
(case (system-type)
[(windows)
[(windows)
(ffi-lib "libatk-1.0-0")
(ffi-lib "libgio-2.0-0")
(ffi-lib "libgdk_pixbuf-2.0-0")
(ffi-lib "libgdk-win32-2.0-0")]
[else (ffi-lib "libgdk-x11-2.0" '("0" ""))]))
[else (if gtk3?
(get-gdk3-lib)
(ffi-lib "libgdk-x11-2.0" '("0" "")))]))
(define gdk_pixbuf-lib
(case (system-type)
[(windows)
(ffi-lib "libgdk_pixbuf-2.0-0")]
[(unix)
(ffi-lib "libgdk_pixbuf-2.0" '("0" ""))]
(if gtk3?
#f
(ffi-lib "libgdk_pixbuf-2.0" '("0" "")))]
[else gdk-lib]))
(define gtk-lib
(case (system-type)
[(windows)
(ffi-lib "libgtk-win32-2.0-0")]
[else (ffi-lib "libgtk-x11-2.0" '("0" ""))]))
[else (if gtk3?
(get-gtk3-lib)
(ffi-lib "libgtk-x11-2.0" '("0" "")))]))
(define-ffi-definer define-gtk gtk-lib)
(define-ffi-definer define-gdk gdk-lib)
@ -119,8 +127,9 @@
(define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer))
(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong))
(define (g_signal_connect obj s proc user-data)
(g_signal_connect_data obj s proc user-data #f 0))
(define G_CONNECT_AFTER 1)
(define (g_signal_connect obj s proc user-data after?)
(g_signal_connect_data obj s proc user-data #f (if after? G_CONNECT_AFTER 0)))
(define-gobj g_object_get (_fun _GtkWidget (_string = "window")
[w : (_ptr o _GdkWindow)]
@ -138,7 +147,8 @@
(define (get-gtk-object-flags gtk)
(GtkObject-flags (cast gtk _pointer _GtkObject-pointer)))
(define (set-gtk-object-flags! gtk v)
(set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v))
(unless gtk3?
(set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v)))
(define-gmodule g_module_open (_fun _path _int -> _pointer))
@ -151,8 +161,8 @@
(define handler-proc proc)
(define handler_function
(function-ptr handler-proc (_fun #:atomic? #t . args)))
(define (connect-name gtk [user-data #f])
(g_signal_connect gtk signal-name handler_function user-data))))
(define (connect-name gtk [user-data #f] #:after? [after? #f])
(g_signal_connect gtk signal-name handler_function user-data after?))))
(define _gpath/free

72
gui-lib/mred/private/wx/gtk/window.rkt
View File

@ -30,8 +30,16 @@
gtk_widget_add_events
gtk_widget_size_request
gtk_widget_set_size_request
gtk_widget_size_allocate
gtk_widget_get_preferred_size
gtk_widget_grab_focus
gtk_widget_has_focus
gtk_widget_get_mapped
gtk_widget_get_has_window
gtk_widget_set_can_default
gtk_widget_set_can_focus
gtk_widget_set_sensitive
gtk_widget_get_scale_factor
connect-focus
connect-key
@ -88,6 +96,10 @@
(define-gtk gtk_widget_grab_focus (_fun _GtkWidget -> _void))
(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean))
(define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_widget_get_preferred_size (_fun _GtkWidget _GtkRequisition-pointer/null _GtkRequisition-pointer/null -> _void)
#:fail (lambda () #f))
(define-gtk gtk_widget_get_scale_factor (_fun _GtkWidget -> _int)
#:fail (lambda () (lambda (gtk) 1)))
(define-gdk gdk_keyboard_grab (_fun _GdkWindow _gboolean _int -> _void))
(define-gdk gdk_keyboard_ungrab (_fun _int -> _void))
@ -99,6 +111,7 @@
(define the-accelerator-group (gtk_accel_group_new))
;; Only for Gtk2
(define-cstruct _GtkWidgetT ([obj _GtkObject]
[private_flags _uint16]
[state _byte]
@ -110,14 +123,45 @@
[window _GdkWindow]
[parent _GtkWidget]))
(define (widget-window gtk)
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define-gtk widget-window (_fun _GtkWidget -> _GdkWindow)
#:c-id gtk_widget_get_window
#:fail (lambda ()
(lambda (gtk)
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))))
(define (widget-parent gtk)
(GtkWidgetT-parent (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define-gtk widget-parent (_fun _GtkWidget -> _GdkWindow)
#:c-id gtk_widget_get_parent
#:fail (lambda ()
(lambda (gtk)
(GtkWidgetT-parent (cast gtk _GtkWidget _GtkWidgetT-pointer)))))
(define (widget-allocation gtk)
(GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define-gtk widget-allocation (_fun _GtkWidget (o : (_ptr o _GtkAllocation)) -> _void -> o)
#:c-id gtk_widget_get_allocation
#:fail (lambda ()
(lambda (gtk)
(GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer)))))
;; Fallbacks for old Gtk2 versions:
(define ((get-one-flag flag [wrap values]) gtk)
(wrap (positive? (bitwise-and (get-gtk-object-flags gtk)
flag))))
(define ((set-one-flag! flag) gtk on?)
(define v (get-gtk-object-flags gtk))
(set-gtk-object-flags! gtk
(if on?
(bitwise-ior v flag)
(bitwise-and v (bitwise-not flag)))))
(define-gtk gtk_widget_has_focus (_fun _GtkWidget -> _gboolean)
#:fail (lambda () (get-one-flag GTK_HAS_FOCUS)))
(define-gtk gtk_widget_get_mapped (_fun _GtkWidget -> _gboolean)
#:fail (lambda () (get-one-flag GTK_MAPPED)))
(define-gtk gtk_widget_get_has_window (_fun _GtkWidget -> _gboolean)
#:fail (lambda () (get-one-flag GTK_NO_WINDOW not)))
(define-gtk gtk_widget_set_can_default (_fun _GtkWidget _gboolean -> _void)
#:fail (lambda () (set-one-flag! GTK_CAN_DEFAULT)))
(define-gtk gtk_widget_set_can_focus (_fun _GtkWidget _gboolean -> _void)
#:fail (lambda () (set-one-flag! GTK_CAN_FOCUS)))
(define-gtk gtk_drag_dest_add_uri_targets (_fun _GtkWidget -> _void))
(define-gtk gtk_drag_dest_set (_fun _GtkWidget _int (_pointer = #f) (_int = 0) _int -> _void))
@ -532,12 +576,14 @@
(set! client-delta-w dw)
(set! client-delta-h dh))
(define/public (infer-client-delta [w? #t] [h? #t] [sub-h-gtk #f])
(define/public (infer-client-delta [w? #t] [h? #t] [sub-h-gtk #f]
#:inside [inside-gtk (get-container-gtk)])
(let ([req (make-GtkRequisition 0 0)]
[creq (make-GtkRequisition 0 0)]
[hreq (make-GtkRequisition 0 0)])
(when gtk3? (gtk_widget_show gtk))
(gtk_widget_size_request gtk req)
(gtk_widget_size_request (get-container-gtk) creq)
(gtk_widget_size_request inside-gtk creq)
(when sub-h-gtk
(gtk_widget_size_request sub-h-gtk hreq))
(when w?
@ -548,11 +594,17 @@
(when h?
(set! client-delta-h (->normal
(- (GtkRequisition-height req)
(GtkRequisition-height creq)))))))
(GtkRequisition-height creq)))))
(when gtk3? (gtk_widget_show gtk))))
(define/public (set-auto-size [dw 0] [dh 0])
(let ([req (make-GtkRequisition 0 0)])
(gtk_widget_size_request gtk req)
(cond
[gtk3?
(gtk_widget_show gtk)
(gtk_widget_get_preferred_size gtk req #f)
(gtk_widget_hide gtk)]
[else (gtk_widget_size_request gtk req)])
(set-size #f
#f
(+ (->normal (GtkRequisition-width req)) dw)

72
gui-lib/mred/private/wx/gtk/x11.rkt
View File

@ -5,16 +5,33 @@
"utils.rkt")
(provide
(protect-out gdk_pixmap_new
(protect-out define-x11
gdk_pixmap_new
gdk_window_get_display
gdk_drawable_get_display
gdk_drawable_get_visual
gdk_x11_drawable_get_xid
gdk_x11_display_get_xdisplay
gdk_x11_visual_get_xvisual
gdk_x11_screen_get_screen_number))
gdk_x11_screen_get_screen_number
gdk_x11_window_get_xid
_Display
_Window
_Pixmap
XCreatePixmap
XCreateSimpleWindow
XDestroyWindow))
(define x11-lib (ffi-lib "libX11" '("6" "5" "")))
(define-ffi-definer define-x11 x11-lib
#:default-make-fail make-not-available)
(define _GdkDrawable _pointer)
(define _GdkDisplay (_cpointer 'GdkDisplay))
(define _GdkWindow (_cpointer 'GdkWindow))
(define _GdkScreen (_cpointer 'GdkScreen))
(define _GdkVisual (_cpointer 'GdkVisual))
(define _GdkPixmap (_cpointer 'GdkPixmap))
@ -22,15 +39,31 @@
(define _Display (_cpointer 'Display))
(define _Drawable _ulong)
;; This should be `_ulong`, but we use pointers for various
;; reasons, including support for dealloctaors:
(define _Window (_cpointer 'Window))
(define _Pixmap (_cpointer 'Pixmap))
(define-gdk gdk_pixmap_new (_fun _GdkDrawable _int _int _int -> _GdkPixmap)
#:wrap (allocator gobject-unref))
(define-gdk gdk_drawable_get_display (_fun _GdkDrawable -> _GdkDisplay))
(define-gdk gdk_drawable_get_visual (_fun _GdkDrawable -> _GdkVisual))
(define-gdk gdk_x11_drawable_get_xid (_fun _GdkDrawable -> _Drawable)
#:wrap (allocator gobject-unref)
#:make-fail make-not-available)
(define-gdk gdk_drawable_get_display (_fun _GdkDrawable -> _GdkDisplay)
#:make-fail make-not-available)
(define-gdk gdk_window_get_display (_fun _GdkWindow -> _GdkDisplay)
#:make-fail make-not-available)
(define-gdk gdk_drawable_get_visual (_fun _GdkDrawable -> _GdkVisual)
#:make-fail make-not-available)
(define-gtk gdk_x11_window_get_xid (_fun _GdkWindow -> _Window)
#:make-fail make-not-available)
(define-gdk gdk_x11_drawable_get_xid (_fun _GdkDrawable -> _Drawable)
#:fail (lambda () (lambda (d)
(cast
(gdk_x11_window_get_xid (cast d _GdkDrawable _GdkWindow))
_pointer
_ulong))))
(define-gdk gdk_x11_display_get_xdisplay (_fun _GdkDisplay -> _Display)
#:make-fail make-not-available)
@ -39,3 +72,26 @@
(define-gdk gdk_x11_screen_get_screen_number (_fun _GdkScreen -> _int)
#:make-fail make-not-available)
(define-x11 XFreePixmap (_fun _Display _Pixmap -> _void))
(define-x11 XCreatePixmap (_fun _Display _Window _int _int _int -> _Pixmap)
#:wrap (lambda (proc)
(lambda (dpy win w h d)
(((allocator ((deallocator)
(lambda (pixmap)
(XFreePixmap dpy pixmap))))
(lambda ()
(proc dpy win w h d)))))))
(define-x11 XDestroyWindow (_fun _Display _Window -> _void)
#:wrap (deallocator cadr))
(define-x11 XCreateSimpleWindow (_fun _Display _Window
_int _int _int _int
_int _long _long
-> _Window)
#:wrap (lambda (proc)
(lambda (dpy win x y w h bw b bg)
(((allocator (lambda (win)
(XDestroyWindow dpy win)))
(lambda ()
(proc dpy win x y w h bw b bg)))))))

3
gui-lib/mred/private/wx/platform.rkt
View File

@ -78,5 +78,6 @@
make-gl-bitmap
check-for-break
key-symbol-to-menu-key
needs-grow-box-spacer?)
needs-grow-box-spacer?
graphical-system-type)
((dynamic-require platform-lib 'platform-values)))

5
gui-lib/mred/private/wx/win32/procs.rkt
View File

@ -60,7 +60,8 @@
special-option-key
get-color-from-user
key-symbol-to-menu-key
needs-grow-box-spacer?)
needs-grow-box-spacer?
graphical-system-type)
(define (find-graphical-system-path what)
#f)
@ -119,6 +120,8 @@
(define (needs-grow-box-spacer?) #f)
(define (graphical-system-type) 'win32)
(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL)
-> (if r
p