suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Cocoa menus, including on-demand tricks

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-12 13:42:17 -06:00
parent 471a8bc1f8
commit 90b005afed
8 changed files with 221 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -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)))

3
collects/mred/private/wx/cocoa/freeze.rkt
View File

@ -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)))

55
collects/mred/private/wx/cocoa/menu-bar.rkt
View File

@ -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))

55
collects/mred/private/wx/cocoa/menu-item.rkt
View File

@ -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))

55
collects/mred/private/wx/cocoa/menu.rkt
View File

@ -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)))))))

4
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -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)

66
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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))])

5
collects/mred/private/wx/common/queue.rkt
View File

@ -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))