popup menus

collects/mred/private/wx/cocoa/menu.rkt

@@ -3,10 +3,11 @@
          scheme/foreign
          (only-in scheme/list drop take)
          ffi/objc
-          "../../syntax.rkt"
+         "../common/event.rkt"
-          "utils.rkt"
+         "../../syntax.rkt"
-          "types.rkt"
+         "utils.rkt"
-          "window.rkt")
+         "types.rkt"
+         "window.rkt")
 (unsafe!)
 (objc-unsafe!)
 
@@ -28,7 +29,7 @@
   (define cocoa #f)
   (define cocoa-menu #f)
 
-  (define/public (install cocoa-parent label)
+  (define/public (create-menu label)
     (unless cocoa
       (set! cocoa
             (as-objc-allocation
@@ -46,16 +47,42 @@
                   (if item
                       (send (mitem-item item) install cocoa-menu)
                       (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem))))
-                items))
+                items)))
+
+  (define/public (install cocoa-parent label)
+    (create-menu label)
     (tellv cocoa-parent addItem: cocoa))
 
+  (define popup-box #f)
+
+  (define/public (do-popup v x y queue-cb)
+    (unless (null? items)
+      (create-menu "menu")
+      (let ([b (box #f)])
+        (set! popup-box b)
+        (tellv cocoa-menu 
+               popUpMenuPositioningItem: (tell cocoa-menu itemAtIndex: #:type _NSUInteger 0)
+               atLocation: #:type _NSPoint (make-NSPoint x y)
+               inView: v)
+        (set! popup-box #f)
+        (let* ([i (unbox b)]
+               [e (new popup-event% [event-type 'menu-popdown])])
+          (send e set-menu-id i)
+          (queue-cb (lambda () (callback this e)))))))
+  
   (define/public (item-selected menu-item)
     ;; called in Cocoa thread
-    (let ([top (get-top-parent)])
+    (cond
-      (when top
+     [popup-box
-        (queue-window-event
+      (set-box! popup-box menu-item)]
-         top
+     [(parent . is-a? . menu%)
-         (lambda () (send top on-menu-command menu-item))))))
+      (send parent item-selected menu-item)]
+     [else
+      (let ([top (get-top-parent)])
+        (when top
+          (queue-window-event
+           top
+           (lambda () (send top on-menu-command menu-item)))))]))
 
   (define parent #f)
   (define/public (set-parent p) (set! parent p))

collects/mred/private/wx/cocoa/window.rkt

@@ -40,10 +40,10 @@
 (define-objc-mixin (KeyMouseResponder Superclass)
   [wx]
   [-a _void (mouseDown: [_id event]) 
-      (unless (do-mouse-event wx event 'left-down #t #f #f)
+      (unless (do-mouse-event wx event 'left-down #t #f #f 'right-down)
         (super-tell #:type _void mouseDown: event))]
   [-a _void (mouseUp: [_id event]) 
-      (unless (do-mouse-event wx event 'left-up #f #f #f)
+      (unless (do-mouse-event wx event 'left-up #f #f #f 'right-up)
         (super-tell #:type _void mouseUp: event))]
   [-a _void (mouseDragged: [_id event]) 
       (unless (do-mouse-event wx event 'motion #t #f #f)
@@ -112,20 +112,20 @@
                                (lambda () (send wx dispatch-on-char k #t))
                                #t))))))
 
-(define (do-mouse-event wx event kind l? m? r?)
+(define (do-mouse-event wx event kind l? m? r? [ctl-kind kind])
   (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
          [bit? (lambda (m b) (positive? (bitwise-and m b)))]
          [pos (tell #:type _NSPoint event locationInWindow)])
-    (let-values ([(x y) (send wx window-point-to-view pos)])
+    (let-values ([(x y) (send wx window-point-to-view pos)]
+                 [(control-down) (bit? modifiers NSControlKeyMask)])
       (let ([m (new mouse-event%
-                    [event-type kind]
+                    [event-type (if control-down ctl-kind kind)]
-                    [left-down l?]
+                    [left-down (and l? (not control-down))]
                     [middle-down m?]
-                    [right-down r?]
+                    [right-down (or r? (and l? control-down))]
                     [x (->long x)]
                     [y (->long y)]
                     [shift-down (bit? modifiers NSShiftKeyMask)]
-                    [control-down (bit? modifiers NSControlKeyMask)]
                     [meta-down (bit? modifiers NSCommandKeyMask)]
                     [alt-down (bit? modifiers NSAlternateKeyMask)]
                     [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
@@ -312,7 +312,12 @@
     (def/public-unimplemented on-drop-file)
     (def/public-unimplemented get-handle)
     (def/public-unimplemented set-phantom-size)
-    (def/public-unimplemented popup-menu)
+
+    (define/public (popup-menu m x y)
+      (send m do-popup (get-cocoa-content) x (flip-client y)
+            (lambda (thunk)
+              (queue-window-event this thunk))))
+
     (define/public (center a b) (void))
     (def/public-unimplemented refresh)
 

collects/mred/private/wx/common/event.rkt

@@ -91,7 +91,8 @@
   (init-properties [[(symbol-in button check-box choice
                                 list-box list-box-dclick text-field
                                 text-field-enter slider radio-box
-                                menu-popdown menu-popdown-none tab-panel) 
+                                menu-popdown menu-popdown-none tab-panel
+                                menu) 
                      event-type]
                     ;; FIXME: should have no default
                     'button])
@@ -99,7 +100,8 @@
   (super-new [time-stamp time-stamp]))
 
 (defclass popup-event% control-event%
-  (properties [[any? menu-id] 0]))
+  (properties [[any? menu-id] 0])
+  (super-new))
 
 (defclass scroll-event% event%
   (init-properties [[(symbol-in top bottom line-up line-down page-up page-down thumb) event-type]

collects/mred/private/wx/gtk/frame.rkt

@@ -27,6 +27,9 @@
 (define-gtk gtk_window_maximize (_fun _GtkWidget -> _void))
 (define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void))
 (define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void))
+(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int)) 
+                                          -> _void
+                                          -> (values x y)))
 
 (define (handle-delete gtk)
   (let ([wx (gtk->wx gtk)])
@@ -162,7 +165,9 @@
       (pre-on-char w e))
 
     (define/override (client-to-screen x y)
-      (void))
+      (let-values ([(dx dy) (gtk_window_get_position gtk)])
+        (set-box! x (+ (unbox x) dx))
+        (set-box! y (+ (unbox y) dy))))
 
     (def/public-unimplemented on-toolbar-click)
     (def/public-unimplemented on-menu-click)

collects/mred/private/wx/gtk/menu.rkt

@@ -7,7 +7,8 @@
          "types.rkt"
          "const.rkt"
          "utils.rkt"
-         "menu-bar.rkt")
+         "menu-bar.rkt"
+         "../common/event.rkt")
 (unsafe!)
 
 (provide menu%)
@@ -22,6 +23,14 @@
 (define-gtk gtk_check_menu_item_get_active (_fun _GtkWidget -> _gboolean))
 (define-gtk gtk_menu_item_set_label  (_fun _GtkWidget _string -> _void))
 (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
+(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void))
+(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
+
+(define-gtk gtk_get_current_event_time (_fun -> _uint32))
+(define-gtk gtk_menu_popup (_fun _GtkWidget _pointer _pointer 
+                                 (_fun _GtkWidget _pointer _pointer _pointer -> _void)
+                                 _pointer _uint _uint32
+                                 -> _void))
 
 (define-signal-handler connect-menu-item-activate "activate"
   (_fun _GtkWidget -> _void)
@@ -29,6 +38,12 @@
     (let ([wx (gtk->wx gtk)])
       (send wx do-on-select))))
 
+(define-signal-handler connect-menu-deactivate "deactivate"
+  (_fun _GtkWidget -> _void)
+  (lambda (gtk)
+    (let ([wx (gtk->wx gtk)])
+      (send wx do-no-selected))))
+
 (define menu-item-handler%
   (class widget%
     (init gtk)
@@ -41,11 +56,7 @@
     (define/public (get-item) menu-item)
 
     (define/public (do-on-select)
-      (let ([top (send menu get-top-parent)])
+      (send menu do-selected menu-item))
-        (when top
-          (queue-window-event
-           top
-           (lambda () (send top on-menu-command menu-item))))))
 
     (define/public (on-select)
       (send menu on-select-item menu-item))))
@@ -55,11 +66,15 @@
         callback
         font)
 
+  (define cb callback)
+  
   (define gtk (gtk_menu_new))
   (define/public (get-gtk) gtk)
 
   (super-new [gtk gtk])
 
+  (connect-menu-deactivate gtk)
+
   (define items null)
 
   (define parent #f)
@@ -72,6 +87,56 @@
              (send parent get-top-parent)
              (send parent get-top-window))))
 
+  (define on-popup #f)
+  (define cancel-none-box (box #t))
+
+  (define/public (popup x y queue-cb)
+    (set! on-popup queue-cb)
+    (set! cancel-none-box (box #f))
+    (gtk_menu_popup gtk 
+                    #f 
+                    #f
+                    (lambda (menu _x _y _push)
+                      (ptr-set! _x _int x)
+                      (ptr-set! _y _int y)
+                      (ptr-set! _push _gboolean #t))
+                    #f
+                    0
+                    (gtk_get_current_event_time)))
+
+  (define/public (do-selected menu-item)
+    ;; Called in event-pump thread
+    (let ([top (get-top-parent)])
+      (cond
+       [top
+        (queue-window-event
+         top
+         (lambda () (send top on-menu-command menu-item)))]
+       [on-popup
+        (let* ([e (new popup-event% [event-type 'menu-popdown])]
+               [pu on-popup]
+               [cnb cancel-none-box])
+          (set! on-popup #f)
+          (set-box! cancel-none-box #t)
+          (send e set-menu-id menu-item)
+          (pu (lambda () (cb this e))))]
+       [parent (send parent do-selected menu-item)])))
+
+  (define/public (do-no-selected)
+    ;; Queue a none-selected event, but only tentatively, because
+    ;; the selection event may come later and cancel the none-selected
+    ;; event.
+    (when on-popup
+      (let* ([e (new popup-event% [event-type 'menu-popdown])]
+             [pu on-popup]
+             [cnb cancel-none-box])
+        (send e set-menu-id #f)
+        (pu (lambda () 
+              (when (eq? on-popup pu)
+                (set! on-popup #f))
+              (unless (unbox cnb) 
+                (cb this e)))))))
+  
   (define/private (adjust-shortcut item-gtk title)
     (cond
      [(regexp-match #rx"\tCtrl[+](.)$" title)
@@ -124,7 +189,8 @@
   (define/public (set-label item str)
     (let ([gtk (find-gtk item)])
       (when gtk
-        (gtk_menu_item_set_label gtk str))))
+        (gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk) 
+                                          (fixup-mneumonic str)))))
 
   (define/public (enable item on?)
     (let ([gtk (find-gtk item)])

collects/mred/private/wx/gtk/window.rkt

@@ -153,27 +153,37 @@
                                 (GdkEventCrossing-state event)
                                 (GdkEventButton-state event)))]
              [bit? (lambda (m v) (positive? (bitwise-and m v)))]
+             [type (cond
+                    [(= type GDK_MOTION_NOTIFY)
+                     'motion]
+                    [(= type GDK_ENTER_NOTIFY)
+                     'enter]
+                    [(= type GDK_LEAVE_NOTIFY)
+                     'leave]
+                    [(= type GDK_BUTTON_PRESS)
+                     (case (GdkEventButton-button event)
+                       [(1) 'left-down]
+                       [(3) 'right-down]
+                       [else 'middle-down])]
+                    [else
+                     (case (GdkEventButton-button event)
+                       [(1) 'left-up]
+                       [(3) 'right-up]
+                       [else 'middle-up])])]
              [m (new mouse-event%
-                     [event-type (cond
+                     [event-type type]
-                                  [(= type GDK_MOTION_NOTIFY)
+                     [left-down (case type
-                                   'motion]
+                                  [(left-down) #t]
-                                  [(= type GDK_ENTER_NOTIFY)
+                                  [(left-up) #f]
-                                   'enter]
+                                  [else (bit? modifiers GDK_BUTTON1_MASK)])]
-                                  [(= type GDK_LEAVE_NOTIFY)
+                     [middle-down (case type
-                                   'leave]
+                                    [(middle-down) #t]
-                                  [(= type GDK_BUTTON_PRESS)
+                                    [(middle-up) #f]
-                                   (case (GdkEventButton-button event)
+                                    [else (bit? modifiers GDK_BUTTON2_MASK)])]
-                                     [(1) 'left-down]
+                     [right-down (case type
-                                     [(3) 'right-down]
+                                   [(right-down) #t]
-                                     [else 'middle-down])]
+                                   [(right-up) #f]
-                                  [else
+                                   [else (bit? modifiers GDK_BUTTON3_MASK)])]
-                                   (case (GdkEventButton-button event)
-                                     [(1) 'left-up]
-                                     [(3) 'right-up]
-                                     [else 'middle-up])])]
-                     [left-down (bit? modifiers GDK_BUTTON1_MASK)]
-                     [middle-down (bit? modifiers GDK_BUTTON2_MASK)]
-                     [right-down (bit? modifiers GDK_BUTTON2_MASK)]
                      [x (->long ((if motion? 
                                      GdkEventMotion-x 
                                      (if crossing? GdkEventCrossing-x GdkEventButton-x))
@@ -338,7 +348,14 @@
     (def/public-unimplemented on-drop-file)
     (def/public-unimplemented get-handle)
     (def/public-unimplemented set-phantom-size)
-    (def/public-unimplemented popup-menu)
+
+    (define/public (popup-menu m x y)
+      (let ([gx (box x)]
+            [gy (box y)])
+        (client-to-screen gx gy)
+        (send m popup (unbox gx) (unbox gy)
+              (lambda (thunk) (queue-window-event this thunk)))))
+
     (define/public (center a b) (void))
     (define/public (refresh) (void))
 
@@ -349,7 +366,7 @@
         (set-box! x (- (unbox x) (unbox xb)))
         (set-box! y (- (unbox y) (unbox yb)))))
     (define/public (client-to-screen x y)
-      (send parent screen-to-client x y)
+      (send parent client-to-screen x y)
       (set-box! x (+ (unbox x) save-x))
       (set-box! y (+ (unbox y) save-y)))