f42356da3f
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.
247 lines
7.1 KiB
Racket
247 lines
7.1 KiB
Racket
#lang racket/base
|
|
(require racket/promise
|
|
ffi/unsafe
|
|
ffi/unsafe/define
|
|
ffi/unsafe/alloc
|
|
racket/string
|
|
racket/draw/unsafe/glib
|
|
(only-in '#%foreign ctype-c->scheme)
|
|
"gtk3.rkt"
|
|
"../common/utils.rkt"
|
|
"types.rkt"
|
|
"resolution.rkt")
|
|
|
|
(provide
|
|
gtk3?
|
|
define-mz
|
|
define-gobj
|
|
define-glib
|
|
(protect-out define-gtk
|
|
define-gdk
|
|
define-gdk_pixbuf
|
|
|
|
g_object_ref
|
|
g_object_ref_sink
|
|
g_object_unref
|
|
|
|
gobject-ref
|
|
gobject-unref
|
|
as-gobject-allocation
|
|
|
|
as-gtk-allocation
|
|
as-gtk-window-allocation
|
|
clean-up-destroyed
|
|
|
|
g_free
|
|
_gpath/free
|
|
_GSList
|
|
gfree
|
|
|
|
g_object_set_data
|
|
g_object_get_data
|
|
|
|
g_object_new
|
|
|
|
(rename-out [g_object_get g_object_get_window])
|
|
|
|
get-gtk-object-flags
|
|
set-gtk-object-flags!
|
|
|
|
define-signal-handler
|
|
|
|
gdk_screen_get_default
|
|
|
|
;; for declaring derived structures:
|
|
_GtkObject
|
|
|
|
;; window size adjustments for screen scale:
|
|
->screen ->screen* ->normal)
|
|
mnemonic-string)
|
|
|
|
(define gdk-lib
|
|
(case (system-type)
|
|
[(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 (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)
|
|
(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 (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)
|
|
(define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib)
|
|
|
|
(define-gobj g_object_ref (_fun _pointer -> _pointer))
|
|
(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)
|
|
(gtk_widget_destroy v)
|
|
(g_object_unref v))))
|
|
|
|
(define gtk-allocator (allocator remember-to-free-later))
|
|
(define (clean-up-destroyed)
|
|
(free-remembered-now gtk-destroy))
|
|
|
|
(define-syntax-rule (as-gtk-allocation expr)
|
|
((gtk-allocator (lambda () (let ([v expr])
|
|
(g_object_ref_sink v)
|
|
v)))))
|
|
(define-syntax-rule (as-gtk-window-allocation expr)
|
|
((gtk-allocator (lambda () (let ([v expr])
|
|
(g_object_ref v)
|
|
v)))))
|
|
|
|
(define-glib g_free (_fun _pointer -> _void))
|
|
(define gfree ((deallocator) g_free))
|
|
|
|
(define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void))
|
|
(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_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)]
|
|
(_pointer = #f) -> _void -> w))
|
|
|
|
(define-gobj g_object_new (_fun _GType _pointer -> _GtkWidget))
|
|
|
|
;; This seems dangerous, since the shape of GtkObject is not
|
|
;; documented. But it seems to be the only way to get and set
|
|
;; flags.
|
|
(define-cstruct _GtkObject ([type-instance _pointer]
|
|
[ref_count _uint]
|
|
[qdata _pointer]
|
|
[flags _uint32]))
|
|
(define (get-gtk-object-flags gtk)
|
|
(GtkObject-flags (cast gtk _pointer _GtkObject-pointer)))
|
|
(define (set-gtk-object-flags! gtk v)
|
|
(unless gtk3?
|
|
(set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v)))
|
|
|
|
(define-gmodule g_module_open (_fun _path _int -> _pointer))
|
|
|
|
(define-syntax-rule (define-signal-handler
|
|
connect-name
|
|
signal-name
|
|
(_fun . args)
|
|
proc)
|
|
(begin
|
|
(define handler-proc proc)
|
|
(define handler_function
|
|
(function-ptr handler-proc (_fun #:atomic? #t . args)))
|
|
(define (connect-name gtk [user-data #f] #:after? [after? #f])
|
|
(g_signal_connect gtk signal-name handler_function user-data after?))))
|
|
|
|
|
|
(define _gpath/free
|
|
(make-ctype _pointer
|
|
path->bytes ; a Racket bytes can be used as a pointer
|
|
(lambda (x)
|
|
(let ([b (bytes->path (make-byte-string x))])
|
|
(g_free x)
|
|
b))))
|
|
|
|
(define-cstruct _g-slist
|
|
([data _pointer]
|
|
[next (_or-null _g-slist-pointer)]))
|
|
|
|
(define-glib g_slist_free (_fun _g-slist-pointer -> _void))
|
|
;; This should probably be provided by Racket
|
|
(define make-byte-string
|
|
(get-ffi-obj 'scheme_make_byte_string #f (_fun _pointer -> _racket)))
|
|
|
|
(define (_GSList elem)
|
|
(make-ctype (_or-null _g-slist-pointer)
|
|
(lambda (l)
|
|
(let L ([l l])
|
|
(if (null? l)
|
|
#f
|
|
(make-g-slist (car l) (L (cdr l))))))
|
|
(lambda (gl)
|
|
(begin0
|
|
(let L ([gl gl])
|
|
(if (not gl)
|
|
null
|
|
(cons ((ctype-c->scheme elem) (g-slist-data gl))
|
|
(L (g-slist-next gl)))))
|
|
(g_slist_free gl)))))
|
|
|
|
(define-gdk gdk_screen_get_default (_fun -> _GdkScreen))
|
|
|
|
(define (mnemonic-string orig-s)
|
|
(string-join
|
|
(for/list ([s (in-list (regexp-split #rx"&&" orig-s))])
|
|
(regexp-replace*
|
|
#rx"&(.)"
|
|
(regexp-replace*
|
|
#rx"_"
|
|
s
|
|
"__")
|
|
"_\\1"))
|
|
"&"))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define screen-scale-factor/promise
|
|
(delay
|
|
(inexact->exact (get-interface-scale-factor 0))))
|
|
|
|
(define (->screen x)
|
|
(define screen-scale-factor
|
|
(force screen-scale-factor/promise))
|
|
(and x
|
|
(if (= screen-scale-factor 1)
|
|
x
|
|
(if (exact? x)
|
|
(ceiling (* x screen-scale-factor))
|
|
(* x screen-scale-factor)))))
|
|
(define (->screen* x)
|
|
(define screen-scale-factor
|
|
(force screen-scale-factor/promise))
|
|
(if (and (not (= screen-scale-factor 1))
|
|
(exact? x))
|
|
(floor (* x screen-scale-factor))
|
|
(->screen x)))
|
|
|
|
(define (->normal x)
|
|
(define screen-scale-factor
|
|
(force screen-scale-factor/promise))
|
|
(and x
|
|
(if (= screen-scale-factor 1)
|
|
x
|
|
(if (exact? x)
|
|
(floor (/ x screen-scale-factor))
|
|
(/ x screen-scale-factor)))))
|