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