1#lang racket/base
2(require racket/class
3         ffi/unsafe
4         "widget.rkt"
5         "window.rkt"
6          "../../syntax.rkt"
7          "../../lock.rkt"
8         "types.rkt"
9         "const.rkt"
10         "utils.rkt"
11	 "queue.rkt"
12         "menu-bar.rkt"
13         "../common/event.rkt")
14
15(provide
16 (protect-out menu%))
17
18(define-gtk gtk_menu_new (_fun -> _GtkWidget))
19(define-gtk gtk_check_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget))
20(define-gtk gtk_separator_menu_item_new (_fun -> _GtkWidget))
21(define-gdk gdk_unicode_to_keyval (_fun _uint32 -> _uint))
22(define-gtk gtk_menu_item_set_accel_path (_fun _GtkWidget _string -> _void))
23(define-gtk gtk_accel_map_add_entry (_fun _string _uint _int -> _void))
24(define-gtk gtk_check_menu_item_set_active (_fun _GtkWidget _gboolean -> _void))
25(define-gtk gtk_check_menu_item_get_active (_fun _GtkWidget -> _gboolean))
26(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
27(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void))
28(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
29(define-gtk gtk_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void))
30
31(define-gtk gtk_menu_popup (_fun _GtkWidget _pointer _pointer
32                                 (_fun _GtkWidget _pointer _pointer _pointer -> _void)
33                                 _pointer _uint _uint32
34                                 -> _void))
35
36(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))
37(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int))
38(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int))
39
40(define-signal-handler connect-menu-item-activate "activate"
41  (_fun _GtkWidget -> _void)
42  (lambda (gtk)
43    (let ([wx (gtk->wx gtk)])
44      (when wx
45        (send wx do-on-select)))))
46
47(define-signal-handler connect-menu-deactivate "deactivate"
48  (_fun _GtkWidget -> _void)
49  (lambda (gtk)
50    (let ([wx (gtk->wx gtk)])
51      (when wx
52        (send wx do-no-selected)))))
53
54(define menu-item-handler%
55  (class widget%
56    (init gtk)
57    (init-field menu
58                menu-item)
59    (super-new [gtk gtk])
60
61    (connect-menu-item-activate gtk)
62
63    (define/public (get-item) menu-item)
64
65    (define/public (removing-item) (void))
66
67    (define/public (do-on-select)
68      (send menu do-selected menu-item))
69
70    (define/public (on-select)
71      (send menu on-select-item menu-item))))
72
73(define separator-item-handler%
74  (class object%
75    (define/public (get-item) #f)
76    (define/public (removing-item) (void))
77    (super-new)))
78
79;; Globally reference any opened menu, so that the menu object stays alive
80;; while it is displayed, even if no other code refers to it.
81(define global-prevent-gc (make-hasheq))
82
83(defclass menu% widget%
84  (init label
85        callback
86        font)
87
88  (inherit install-widget-parent)
89
90  (define cb callback)
91
92  (define gtk (as-gtk-allocation (gtk_menu_new)))
93  (define/public (get-gtk) gtk)
94
95  (super-new [gtk gtk])
96
97  (connect-menu-deactivate gtk)
98
99  (gtk_menu_set_accel_group gtk the-accelerator-group)
100
101  (define items null)
102
103  (define parent #f)
104  (define/public (set-parent p)
105    (set! parent p)
106    (install-widget-parent p))
107  (define/public (get-top-parent)
108    ;; Maybe be called in Gtk event-handler thread
109    (and parent
110         (if (parent . is-a? . menu%)
111             (send parent get-top-parent)
112             (send parent get-top-window))))
113
114  (define self-item #f)
115  (define remover void)
116  (define/public (set-self-item i r) (set! self-item i) (set! remover r))
117  (define/public (get-item) self-item)
118  (define/public (removing-item)
119    (set! self-item #f)
120    (remover)
121    (set! remover void))
122
123  (define on-popup #f)
124  (define cancel-none-box (box #t))
125
126  (define/public (popup x y queue-cb)
127    ;; Pin the menu object so that it is not garbage collected while displayed
128    (hash-set! global-prevent-gc this #t)
129    (set! on-popup queue-cb)
130    (set! cancel-none-box (box #f))
131    (gtk_menu_popup gtk
132                    #f
133                    #f
134                    (lambda (menu _x _y _push)
135                      (let ([r (make-GtkRequisition 0 0)])
136                        (gtk_widget_size_request menu r)
137                        ;; Try to keep the menu on the screen:
138                        (let* ([s (gtk_widget_get_screen menu)]
139                               [sw (gdk_screen_get_width s)]
140                               [sh (gdk_screen_get_height s)])
141                          (ptr-set! _x _int (min (->screen x)
142                                                 (max 0
143                                                      (- sw
144                                                         (GtkRequisition-width r)))))
145                          (ptr-set! _y _int (min (->screen y)
146                                                 (max 0
147                                                      (- sh
148                                                         (GtkRequisition-height r))))))))
149                    #f
150                    0
151		    recent-event-time))
152
153  (define ignore-callback? #f)
154
155  (define/public (do-selected menu-item)
156    ;; Allow the menu object to be garbage collected again
157    (hash-remove! global-prevent-gc this)
158    ;; Called in event-pump thread
159    (unless ignore-callback?
160      (let ([top (get-top-parent)])
161        (cond
162         [top
163          (queue-window-event
164           top
165           (lambda () (send top on-menu-command menu-item)))]
166         [on-popup
167          (let* ([e (new popup-event% [event-type 'menu-popdown])]
168                 [pu on-popup]
169                 [cnb cancel-none-box])
170            (set! on-popup #f)
171            (set-box! cancel-none-box #t)
172            (send e set-menu-id menu-item)
173            (pu (lambda () (cb this e))))]
174         [parent (send parent do-selected menu-item)]))))
175
176  (define/public (do-no-selected)
177    ;; Allow the menu object to be garbage collected again
178    (hash-remove! global-prevent-gc this)
179    ;; Queue a none-selected event, but only tentatively, because
180    ;; the selection event may come later and cancel the none-selected
181    ;; event.
182    (when on-popup
183      (let* ([e (new popup-event% [event-type 'menu-popdown])]
184             [pu on-popup]
185             [cnb cancel-none-box])
186        (send e set-menu-id #f)
187        (pu (lambda ()
188              (when (eq? on-popup pu)
189                (set! on-popup #f))
190              (unless (unbox cnb)
191                (cb this e)))))))
192
193  (define/private (adjust-shortcut item-gtk title need-clear?)
194    (let ([m (regexp-match #rx"\t(Ctrl[+])?(Shift[+])?(Meta[+])?(Alt[+])?(.|[0-9]+)$"
195                           title)])
196      (if m
197          (let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0)
198                         (if (list-ref m 2) GDK_SHIFT_MASK 0)
199                         (if (list-ref m 3) GDK_MOD1_MASK 0)
200                         (if (list-ref m 4) GDK_META_MASK 0))]
201                [code (let ([s (list-ref m 5)])
202                        (if (= 1 (string-length s))
203                            (gdk_unicode_to_keyval
204                             (char->integer (string-ref s 0)))
205                            (string->number s)))])
206            (unless (zero? code)
207              (let ([accel-path (format "<GRacket>/Hardwired/~a" title)])
208                (gtk_accel_map_add_entry accel-path
209                                         code
210                                         mask)
211                (gtk_menu_item_set_accel_path item-gtk accel-path))))
212          (when need-clear?
213            (gtk_menu_item_set_accel_path item-gtk #f)))))
214
215  (public [append-item append])
216  (define (append-item i label help-str-or-submenu chckable?)
217    (atomically
218     (let ([item-gtk (let ([label (fixup-mnemonic label)])
219                       (as-gtk-allocation
220                        ((if (and chckable?
221                                  (not (help-str-or-submenu . is-a? . menu%)))
222                             gtk_check_menu_item_new_with_mnemonic
223                             gtk_menu_item_new_with_mnemonic)
224                         label)))])
225       (if (help-str-or-submenu . is-a? . menu%)
226           (let ([submenu help-str-or-submenu])
227             (let ([gtk (send submenu get-gtk)])
228               (g_object_ref gtk)
229               (gtk_menu_item_set_submenu item-gtk gtk)
230               (send submenu set-parent this)
231               (send submenu set-self-item i
232                     (lambda () (gtk_menu_item_set_submenu item-gtk #f)))
233               (set! items (append items (list (list submenu item-gtk label chckable?))))))
234           (let ([item (new menu-item-handler%
235                            [gtk item-gtk]
236                            [menu this]
237                            [menu-item i]
238                            [parent this])])
239             (set! items (append items (list (list item item-gtk label chckable?))))
240             (adjust-shortcut item-gtk label #f)))
241       (gtk_menu_shell_append gtk item-gtk)
242       (gtk_widget_show item-gtk))))
243
244  (define/public (append-separator)
245    (atomically
246     (let ([item-gtk (as-gtk-allocation (gtk_separator_menu_item_new))])
247       (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f))))
248       (gtk_menu_shell_append gtk item-gtk)
249       (gtk_widget_show item-gtk))))
250
251  (define/public (select bm)
252    (send parent activate-item this))
253
254  (def/public-unimplemented get-font)
255  (def/public-unimplemented set-width)
256  (def/public-unimplemented set-title)
257
258  (define/public (set-help-string m s) (void))
259
260  (define/public (number) (length items))
261
262  (define/private (find-gtk item)
263    (for/or ([i items])
264      (and (car i)
265           (eq? (send (car i) get-item) item)
266           (cadr i))))
267
268  (define/public (set-label item str)
269    (let ([gtk (find-gtk item)])
270      (when gtk
271        (gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk)
272                                          (fixup-mnemonic str))
273        (adjust-shortcut gtk str #t))))
274
275  (define/public (enable item on?)
276    (let ([gtk (find-gtk item)])
277      (when gtk
278        (gtk_widget_set_sensitive gtk on?))))
279
280  (define/public (check item on?)
281    (let ([gtk (find-gtk item)])
282      (when gtk
283        (atomically
284         (set! ignore-callback? #t)
285         (gtk_check_menu_item_set_active gtk on?)
286         (set! ignore-callback? #f)))))
287
288  (define/public (checked? item)
289    (let ([gtk (find-gtk item)])
290      (when gtk
291        (gtk_check_menu_item_get_active gtk))))
292
293  (define/public (delete-by-position pos)
294    (set! items
295          (let loop ([items items]
296                     [pos pos])
297            (cond
298             [(null? items) null]
299             [(zero? pos)
300              (send (caar items) removing-item)
301              (gtk_container_remove gtk (cadar items))
302              (cdr items)]
303             [else (cons (car items)
304                         (loop (cdr items) (sub1 pos)))]))))
305
306  (define/public (delete item)
307    (set! items
308          (let loop ([items items])
309            (cond
310             [(null? items) null]
311             [(eq? (send (caar items) get-item) item)
312              (send (caar items) removing-item)
313              (gtk_container_remove gtk (cadar items))
314              (cdr items)]
315             [else (cons (car items)
316                         (loop (cdr items)))])))))
317