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