From 90b005afed683662ed959572609570c5ad185888 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Jul 2010 13:42:17 -0600 Subject: [PATCH] Cocoa menus, including on-demand tricks --- collects/mred/private/wx/cocoa/frame.rkt | 15 +++-- collects/mred/private/wx/cocoa/freeze.rkt | 3 +- collects/mred/private/wx/cocoa/menu-bar.rkt | 55 ++++++++++++++-- collects/mred/private/wx/cocoa/menu-item.rkt | 55 +++++++++++++++- collects/mred/private/wx/cocoa/menu.rkt | 55 ++++++++++++---- collects/mred/private/wx/cocoa/procs.rkt | 4 +- collects/mred/private/wx/cocoa/queue.rkt | 66 ++++++++++++++++++-- collects/mred/private/wx/common/queue.rkt | 5 +- 8 files changed, 221 insertions(+), 37 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 6d128e7168..669ba55327 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -57,12 +57,16 @@ (queue-window-event wx (lambda () (send wx on-activate #f))))]) +(set-front-hook! (lambda () (values front + (and front (send front get-eventspace))))) + (set-eventspace-hook! (lambda (w) - (and w - (if (objc-is-a? w MyWindow) - (tell #:type _scheme w getEventspace) - (and front - (send front get-eventspace)))))) + (or (and w + (if (objc-is-a? w MyWindow) + (tell #:type _scheme w getEventspace) + #f)) + (and front + (send front get-eventspace))))) (define (init-pos x y) (if (and (= x -11111) @@ -194,6 +198,7 @@ (define/public (get-menu-bar) mb) (define/public (set-menu-bar _mb) (set! mb _mb) + (send mb set-top-window this) (when (tell #:type _BOOL cocoa isMainWindow) (install-mb))) diff --git a/collects/mred/private/wx/cocoa/freeze.rkt b/collects/mred/private/wx/cocoa/freeze.rkt index b9ad42b4e7..cfcf2ff41d 100644 --- a/collects/mred/private/wx/cocoa/freeze.rkt +++ b/collects/mred/private/wx/cocoa/freeze.rkt @@ -38,7 +38,8 @@ (unless done? (loop))) result) (begin - (fprintf (current-error-port) "WARNING: internal error: wrong eventspace for constrained event handling\n") + (eprintf "WARNING: internal error: wrong eventspace for constrained event handling\n") + (eprintf "~s\n" (continuation-mark-set->context (current-continuation-marks))) default))) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 54360f0371..1e18a9deb2 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -5,13 +5,14 @@ "../../syntax.rkt" "utils.rkt" "types.rkt" - "const.rkt") + "const.rkt" + "queue.rkt") (unsafe!) (objc-unsafe!) (provide menu-bar%) -(import-class NSApplication NSMenu NSMenuItem NSProcessInfo) +(import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) (define-cf CFBundleGetMainBundle (_fun -> _pointer)) (define-cf CFBundleGetInfoDictionary (_fun _pointer -> _id)) @@ -31,7 +32,37 @@ appName)))))) "MrEd")) -(define cocoa-mb (tell (tell NSMenu alloc) init)) +(define-objc-class MyBarMenu NSMenu + [] + ;; Disable automatic handling of keyboard shortcuts + (-a _BOOL (performKeyEquivalent: [_id evt]) + #f)) + +(define cocoa-mb (tell (tell MyBarMenu alloc) init)) +(define current-mb #f) + +;; Used to detect mouse click on the menu bar: +(define in-menu-bar-range + (let ([f (tell #:type _NSRect + (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0) + frame)]) + (let ([x (NSPoint-x (NSRect-origin f))] + [w (NSSize-width (NSRect-size f))] + [y (+ (NSPoint-y (NSRect-origin f)) + (NSSize-height (NSRect-size f)))]) + (lambda (p) + (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) + (and (<= x (NSPoint-x p) (+ x w)) + (<= (- y h) (NSPoint-y p) y))))))) + +(define suspend-menu-bar + (lambda (on?) + ;; We don't actually suspend anything, since the MrEd layer + ;; will drop events that shouldn't be delivered. + (void))) + +(set-menu-bar-hooks! in-menu-bar-range + suspend-menu-bar) ;; Init menu bar (let ([app (tell NSApplication sharedApplication)] @@ -98,7 +129,8 @@ (public [append-menu append]) (define (append-menu menu title) - (set! menus (append menus (list (cons menu title))))) + (set! menus (append menus (list (cons menu title)))) + (send menu set-parent this)) (define/public (install) (let loop () @@ -107,6 +139,19 @@ (loop))) (for-each (lambda (menu) (send (car menu) install cocoa-mb (cdr menu))) - menus)) + menus) + (set! current-mb this)) + + (define top-wx #f) + (define/public (set-top-window top) + (set! top-wx top)) + (define/public (get-top-window) + top-wx) + + (define/public (do-on-menu-click) + (let ([es (send top-wx get-eventspace)]) + (when es + (queue-event es (lambda () + (send top-wx on-menu-click)))))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 932cf20720..12999b1acf 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -4,7 +4,8 @@ ffi/objc "../../syntax.rkt" "utils.rkt" - "types.rkt") + "types.rkt" + "const.rkt") (unsafe!) (objc-unsafe!) @@ -12,15 +13,63 @@ (import-class NSMenuItem) +(define-objc-class MyMenuItem NSMenuItem + [wx] + (-a _void (selected: [_id sender]) (send wx selected))) + + (defclass menu-item% object% (define/public (id) this) + + (define parent #f) + (define/public (selected) + ;; called in Cocoa thread + (send parent item-selected this)) - (define/public (install menu label) - (let ([item (tell (tell NSMenuItem alloc) + (define/public (set-parent p) + (set! parent p)) + + (define label #f) + (define/public (set-label l) (set! label l)) + (define/public (get-label) label) + + (define checked? #f) + (define/public (set-checked c?) (set! checked? c?)) + (define/public (get-checked) checked?) + + (define enabled? #t) + (define/public (set-enabled-flag e?) (set! enabled? e?)) + (define/public (get-enabled-flag) enabled?) + + (define/public (install menu) + (let ([item (tell (tell MyMenuItem alloc) initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") action: #:type _SEL #f keyEquivalent: #:type _NSString "")]) + (set-ivar! item wx this) (tellv menu addItem: item) + (tellv item setEnabled: #:type _BOOL enabled?) + (tellv item setTarget: item) + (tellv item setAction: #:type _SEL (selector selected:)) + (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) + (when shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) (tellv item release))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 394e3763fe..cbc1e1bd0d 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -1,10 +1,12 @@ #lang scheme/base (require scheme/class scheme/foreign + (only-in scheme/list drop take) ffi/objc "../../syntax.rkt" "utils.rkt" - "types.rkt") + "types.rkt" + "window.rkt") (unsafe!) (objc-unsafe!) @@ -12,10 +14,7 @@ (import-class NSMenu NSMenuItem) -(define-struct mitem (item - [label #:mutable] - [checked? #:mutable] - [enabled? #:mutable])) +(define-struct mitem (item)) (defclass menu% object% (init-field label @@ -41,19 +40,39 @@ (as-objc-allocation (tell (tell NSMenu alloc) initWithTitle: #:type _NSString label))) + (tellv cocoa-menu setAutoenablesItems: #:type _BOOL #f) (tellv cocoa setSubmenu: cocoa-menu) (for-each (lambda (item) (if item - (send (mitem-item item) install cocoa-menu (mitem-label item)) + (send (mitem-item item) install cocoa-menu) (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) items)) (tellv cocoa-parent addItem: cocoa)) + (define/public (item-selected menu-item) + ;; called in Cocoa thread + (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)) + (define/public (get-top-parent) + ;; called in Cocoa thread + (and parent + (if (parent . is-a? . menu%) + (send parent get-top-parent) + (send parent get-top-window)))) + (public [append-item append]) (define (append-item i label help-str chckable?) - (set! items (append items (list (make-mitem i label #f #f)))) + (send i set-label label) + (set! items (append items (list (make-mitem i)))) + (send i set-parent this) (when cocoa-menu - (send i install cocoa-menu label))) + (send i install cocoa-menu))) (define/public (append-separator) (set! items (append items (list #f))) @@ -87,22 +106,32 @@ (lambda (item-cocoa) (tellv item-cocoa setTitle: #:type _NSString label)) (lambda (mitem) - (set-mitem-label! mitem label)))) + (send (mitem-item mitem) set-label label)))) (define/public (check item on?) (adjust item (lambda (item-cocoa) (tellv item-cocoa setState: #:type _int (if on? 1 0))) (lambda (mitem) - (set-mitem-checked?! mitem (and on? #t))))) + (send (mitem-item mitem) set-checked (and on? #t))))) (define/public (enable item on?) (adjust item (lambda (item-cocoa) (tellv item-cocoa setEnabled: #:type _BOOL on?)) (lambda (mitem) - (set-mitem-enabled?! mitem (and on? #t))))) + (send (mitem-item mitem) set-enabled-flag (and on? #t))))) - (def/public-unimplemented checked?) + (define/public (checked? item) + (send item get-checked)) + (def/public-unimplemented delete-by-position) - (def/public-unimplemented delete)) + + (define/public (delete item) + (let ([pos (find-pos item)]) + (when pos + (let ([mitem (list-ref items pos)]) + (set! items (append (take items pos) + (drop items (add1 pos)))) + (when cocoa-menu + (tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos))))))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 3567a33b59..b58496d645 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -111,7 +111,7 @@ (set-box! xb (->long (NSSize-width (NSRect-size f)))) (set-box! yb (->long (NSSize-height (NSRect-size f)))))) -(define-unimplemented bell) +(define (bell) (void)) (define (hide-cursor) (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) @@ -123,7 +123,7 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) (define-unimplemented file-selector) -(define-unimplemented id-to-menu-item) +(define (id-to-menu-item id) id) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index b2ecb480d9..76e3cb479d 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require ffi/objc scheme/foreign + scheme/class "pool.rkt" "utils.rkt" "const.rkt" @@ -16,6 +17,8 @@ cocoa-install-event-wakeup queue-event set-eventspace-hook! + set-front-hook! + set-menu-bar-hooks! ;; from common/queue: current-eventspace @@ -31,13 +34,24 @@ [] [-a _BOOL (applicationShouldTerminate: [_id app]) (queue-quit-event) - #t]) + #f]) (tellv app finishLaunching) -(tellv app setDelegate: (tell (tell MyApplicationDelegate alloc) init)) +(define app-delegate (tell (tell MyApplicationDelegate alloc) init)) +(tellv app setDelegate: app-delegate) (tellv app activateIgnoringOtherApps: #:type _BOOL #t) +#| +(import-class NSNotificationCenter) +(define-cocoa NSMenuDidBeginTrackingNotification _id) +(tellv (tell NSNotificationCenter defaultCenter) + addObserver: app-delegate + selector: #:type _SEL (selector trackingMenuNow:) + name: NSMenuDidBeginTrackingNotification + object: #f) +|# + ;; ------------------------------------------------------------ ;; Create an event to post when MzScheme has been sleeping but is ;; ready to wake up @@ -143,15 +157,55 @@ (define eventspace-hook (lambda (e) #f)) (define (set-eventspace-hook! proc) (set! eventspace-hook proc)) +(define front-hook (lambda () (values #f #f))) +(define (set-front-hook! proc) (set! front-hook proc)) + +(define in-menu-bar-range? (lambda (p) #f)) +(define suspend-menu-bar (lambda (suspend?) (void))) +(define (set-menu-bar-hooks! r? s) + (set! in-menu-bar-range? r?) + (set! suspend-menu-bar s)) + +(define events-suspended? #f) + +(define (check-menu-bar-click evt) + (when (and evt + (= 14 (tell #:type _NSUInteger evt type)) + (= 7 (tell #:type _short evt subtype)) + (not (tell evt window)) + (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow))) + ;; Mouse down in the menu bar: + (let-values ([(f e) (front-hook)]) + (when e + ;; Don't handle further events until we've made an effort + ;; at on-demand notifications. + (set! events-suspended? #t) + (let ([t (thread (lambda () + (sleep 2) + ;; on-demand took too long, so disable the menu bar + ;; until the application can catch up + (suspend-menu-bar #t) + (set! events-suspended? #f)))]) + (queue-event e (lambda () + (send f on-menu-click) + (set! events-suspended? #f) + (kill-thread t)))))))) + ;; Call this function only in atomic mode: (define (check-one-event wait? dequeue?) (pre-event-sync wait?) (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) + (when (and events-suspended? wait?) + (suspend-menu-bar #t) + (set! events-suspended? #f)) (begin0 - (let ([evt (tell app nextEventMatchingMask: #:type _NSUInteger NSAnyEventMask - untilDate: (if wait? distantFuture #f) - inMode: NSDefaultRunLoopMode - dequeue: #:type _BOOL dequeue?)]) + (let ([evt (if events-suspended? + #f + (tell app nextEventMatchingMask: #:type _NSUInteger NSAnyEventMask + untilDate: (if wait? distantFuture #f) + inMode: NSDefaultRunLoopMode + dequeue: #:type _BOOL dequeue?))]) + (when evt (check-menu-bar-click evt)) (and evt (or (not dequeue?) (let ([e (eventspace-hook (tell evt window))]) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 80c4414f52..e37778f5c0 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -3,7 +3,8 @@ racket/draw/utils ffi/unsafe/atomic "rbtree.rkt" - "../../lock.rkt") + "../../lock.rkt" + "handlers.rkt") (provide queue-evt set-check-queue! @@ -317,4 +318,4 @@ 'frame-remove))) (define (queue-quit-event) - (printf "quit!\n")) + (queue-event main-eventspace (application-quit-handler) 'med))