1#lang racket/base 2(require racket/promise 3 ffi/unsafe 4 ffi/unsafe/define 5 ffi/unsafe/alloc 6 racket/string 7 racket/draw/unsafe/glib 8 racket/draw/unsafe/bstr 9 (only-in '#%foreign ctype-c->scheme) 10 "gtk3.rkt" 11 "../common/utils.rkt" 12 "types.rkt" 13 "resolution.rkt") 14 15(provide 16 gtk3? 17 define-mz 18 define-gobj 19 define-glib 20 (protect-out define-gtk 21 define-gdk 22 define-gdk_pixbuf 23 24 g_object_ref 25 g_object_ref_sink 26 g_object_unref 27 28 gobject-ref 29 gobject-unref 30 as-gobject-allocation 31 32 as-gtk-allocation 33 as-gtk-window-allocation 34 clean-up-destroyed 35 36 g_free 37 _gpath/free 38 _GSList 39 gfree 40 41 g_object_set_data 42 g_object_get_data 43 44 g_object_new 45 46 (rename-out [g_object_get g_object_get_window]) 47 48 get-gtk-object-flags 49 set-gtk-object-flags! 50 51 define-signal-handler 52 53 gdk_screen_get_default 54 55 gtk_get_minor_version 56 57 ;; for declaring derived structures: 58 _GtkObject 59 60 ;; window size adjustments for screen scale: 61 ->screen ->screen* ->normal) 62 mnemonic-string) 63 64(define gdk-lib 65 (case (system-type) 66 [(windows) 67 (ffi-lib "libatk-1.0-0") 68 (ffi-lib "libgio-2.0-0") 69 (ffi-lib "libgdk_pixbuf-2.0-0") 70 (ffi-lib "libgdk-win32-2.0-0")] 71 [else (if gtk3? 72 (get-gdk3-lib) 73 (ffi-lib "libgdk-x11-2.0" '("0" "")))])) 74(define gdk_pixbuf-lib 75 (case (system-type) 76 [(windows) 77 (ffi-lib "libgdk_pixbuf-2.0-0")] 78 [(unix) 79 (if gtk3? 80 #f 81 (ffi-lib "libgdk_pixbuf-2.0" '("0" "")))] 82 [else gdk-lib])) 83(define gtk-lib 84 (case (system-type) 85 [(windows) 86 (ffi-lib "libgtk-win32-2.0-0")] 87 [else (if gtk3? 88 (get-gtk3-lib) 89 (ffi-lib "libgtk-x11-2.0" '("0" "")))])) 90 91(define-ffi-definer define-gtk gtk-lib) 92(define-ffi-definer define-gdk gdk-lib) 93(define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) 94 95(define-gobj g_object_ref (_fun _pointer -> _pointer)) 96(define-gobj g_object_unref (_fun _pointer -> _void)) 97(define-gobj g_object_ref_sink (_fun _pointer -> _pointer)) 98 99(define gobject-unref ((deallocator) g_object_unref)) 100(define gobject-ref ((allocator gobject-unref) g_object_ref)) 101 102(define-syntax-rule (as-gobject-allocation expr) 103 ((gobject-allocator (lambda () expr)))) 104 105(define gobject-allocator (allocator gobject-unref)) 106 107(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void)) 108 109(define gtk-destroy ((deallocator) (lambda (v) 110 (gtk_widget_destroy v) 111 (g_object_unref v)))) 112 113(define gtk-allocator (allocator remember-to-free-later)) 114(define (clean-up-destroyed) 115 (free-remembered-now gtk-destroy)) 116 117(define-syntax-rule (as-gtk-allocation expr) 118 ((gtk-allocator (lambda () (let ([v expr]) 119 (g_object_ref_sink v) 120 v))))) 121(define-syntax-rule (as-gtk-window-allocation expr) 122 ((gtk-allocator (lambda () (let ([v expr]) 123 (g_object_ref v) 124 v))))) 125 126(define-glib g_free (_fun _pointer -> _void)) 127(define gfree ((deallocator) g_free)) 128 129(define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) 130(define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) 131 132(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong)) 133(define G_CONNECT_AFTER 1) 134(define (g_signal_connect obj s proc user-data after?) 135 (g_signal_connect_data obj s proc user-data #f (if after? G_CONNECT_AFTER 0))) 136 137(define-gobj g_object_get (_fun _GtkWidget (_string = "window") 138 [w : (_ptr o _GdkWindow)] 139 (_pointer = #f) -> _void -> w)) 140 141(define-gobj g_object_new (_fun _GType _pointer -> _GtkWidget)) 142 143;; This seems dangerous, since the shape of GtkObject is not 144;; documented. But it seems to be the only way to get and set 145;; flags. 146(define-cstruct _GtkObject ([type-instance _pointer] 147 [ref_count _uint] 148 [qdata _pointer] 149 [flags _uint32])) 150(define (get-gtk-object-flags gtk) 151 (GtkObject-flags (cast gtk _pointer _GtkObject-pointer))) 152(define (set-gtk-object-flags! gtk v) 153 (unless gtk3? 154 (set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v))) 155 156(define-gmodule g_module_open (_fun _path _int -> _pointer)) 157 158(define-syntax-rule (define-signal-handler 159 connect-name 160 signal-name 161 (_fun . args) 162 proc) 163 (begin 164 (define handler-proc proc) 165 (define handler_function 166 (function-ptr handler-proc (_fun #:atomic? #t . args))) 167 (define (connect-name gtk [user-data #f] #:after? [after? #f]) 168 (g_signal_connect gtk signal-name handler_function user-data after?)))) 169 170 171(define _gpath/free 172 (make-ctype _pointer 173 path->bytes ; a Racket bytes can be used as a pointer 174 (lambda (x) 175 (let ([b (bytes->path (make-byte-string x))]) 176 (g_free x) 177 b)))) 178 179(define-cstruct _g-slist 180 ([data _pointer] 181 [next (_or-null _g-slist-pointer)])) 182 183(define-glib g_slist_free (_fun _g-slist-pointer -> _void)) 184(define (make-byte-string s) 185 (scheme_make_sized_byte_string s -1 1)) 186 187(define (_GSList elem) 188 (make-ctype (_or-null _g-slist-pointer) 189 (lambda (l) 190 (let L ([l l]) 191 (if (null? l) 192 #f 193 (make-g-slist (car l) (L (cdr l)))))) 194 (lambda (gl) 195 (begin0 196 (let L ([gl gl]) 197 (if (not gl) 198 null 199 (cons ((ctype-c->scheme elem) (g-slist-data gl)) 200 (L (g-slist-next gl))))) 201 (g_slist_free gl))))) 202 203(define-gdk gdk_screen_get_default (_fun -> _GdkScreen)) 204 205(define-gtk gtk_get_minor_version (_fun -> _uint) 206 #:fail (lambda () (lambda () 0))) 207 208(define (mnemonic-string orig-s) 209 (string-join 210 (for/list ([s (in-list (regexp-split #rx"&&" orig-s))]) 211 (regexp-replace* 212 #rx"&(.)" 213 (regexp-replace* 214 #rx"_" 215 s 216 "__") 217 "_\\1")) 218 "&")) 219 220;; ---------------------------------------- 221 222(define screen-scale-factor/promise 223 (delay 224 (inexact->exact (get-interface-scale-factor 0)))) 225 226(define (->screen x) 227 (define screen-scale-factor 228 (force screen-scale-factor/promise)) 229 (and x 230 (if (= screen-scale-factor 1) 231 x 232 (if (exact? x) 233 (ceiling (* x screen-scale-factor)) 234 (* x screen-scale-factor))))) 235(define (->screen* x) 236 (define screen-scale-factor 237 (force screen-scale-factor/promise)) 238 (if (and (not (= screen-scale-factor 1)) 239 (exact? x)) 240 (floor (* x screen-scale-factor)) 241 (->screen x))) 242 243(define (->normal x) 244 (define screen-scale-factor 245 (force screen-scale-factor/promise)) 246 (and x 247 (if (= screen-scale-factor 1) 248 x 249 (if (exact? x) 250 (floor (/ x screen-scale-factor)) 251 (/ x screen-scale-factor))))) 252