#lang racket/base (require racket/class ffi/unsafe ffi/unsafe/objc (only-in racket/list take drop) "../../syntax.rkt" "../../lock.rkt" "utils.rkt" "types.rkt" "const.rkt" "queue.rkt") (provide (protect-out menu-bar% get-menu-bar-height)) (import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) (define-cf CFBundleGetMainBundle (_fun -> _pointer)) (define-cf CFBundleGetInfoDictionary (_fun _pointer -> _id)) (define app-name (or (let ([dict (CFBundleGetInfoDictionary (CFBundleGetMainBundle))]) (and dict (let ([appName (tell dict objectForKey: #:type _NSString "CFBundleName")] [alt (lambda () (tell #:type _NSString (tell NSProcessInfo processInfo) processName))]) (if (not appName) (alt) (let ([appName (cast appName _id _NSString)]) (if (equal? appName "") (alt) appName)))))) "MrEd")) (define the-apple-menu #f) (define recurring-for-command (make-parameter #f)) (define-objc-class MyBarMenu NSMenu [] ;; Disable automatic handling of keyboard shortcuts, except for ;; the Apple menu (-a _BOOL (performKeyEquivalent: [_id evt]) (or (and the-apple-menu (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) ;; Explicity send the event to the keyWindow: (and ;; Don't go into an infinite loop: (not (recurring-for-command)) ;; Don't handle Cmd-` for cycling through windows: ;; [Is this right for all locales?] (not (equal? "`" (tell #:type _NSString evt characters))) ;; Otherwise, try to dispatch to the first respnder: (let ([w (tell app keyWindow)]) (and w (let ([r (tell w firstResponder)]) (and r (begin (parameterize ([recurring-for-command #t]) (let ([evt-type (tell #:type _NSInteger evt type)]) (cond [(= NSKeyDown evt-type) (tell r keyDown: evt)] [(= NSKeyUp evt-type) (tell r keyUp: evt)]))) #t))))))))) (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 (get-menu-bar-height) (inexact->exact (floor (tell #:type _CGFloat cocoa-mb menuBarHeight)))) (set-menu-bar-hooks! in-menu-bar-range) ;; Init menu bar (let ([app (tell NSApplication sharedApplication)] [add-one (lambda (mb menu) (let ([item (tell (tell NSMenuItem alloc) initWithTitle: #:type _NSString "" action: #:type _SEL #f keyEquivalent: #:type _NSString "")]) (tellv item setSubmenu: menu) (tellv mb addItem: item) (tellv item release)))]) (let ([apple (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "")]) (let ([std (lambda (title sel [shortcut ""] [mods #f] [delegate? #f]) (let ([item (tell (tell NSMenuItem alloc) initWithTitle: #:type _NSString title action: #:type _SEL sel keyEquivalent: #:type _NSString shortcut)]) (when mods (tellv item setKeyEquivalentModifierMask: #:type _NSInteger mods)) (tellv item setTarget: (if delegate? (tell app delegate) app)) (tellv apple addItem: item) (tellv item release)))]) (std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) (std "Preferences..." (selector openPreferences:) "," #f #t) (tellv apple addItem: (tell NSMenuItem separatorItem)) (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) (tellv app setServicesMenu: services) (let ([item (tell (tell NSMenuItem alloc) initWithTitle: #:type _NSString "Services" action: #:type _SEL #f keyEquivalent: #:type _NSString "")]) (tellv item setSubmenu: services) (tellv apple addItem: item) (tellv item release))) (tellv apple addItem: (tell NSMenuItem separatorItem)) (std (format "Hide ~a" app-name) (selector hide:) "h") (std "Hide Others" (selector hideOtherApplications:) "h" (bitwise-ior NSAlternateKeyMask NSCommandKeyMask)) (std "Show All" (selector unhideAllApplications:)) (tellv apple addItem: (tell NSMenuItem separatorItem)) (std (format "Quit ~a" app-name) (selector terminate:) "q")) (add-one cocoa-mb apple) (tellv app setAppleMenu: apple) (tellv apple release) (tellv app setMainMenu: cocoa-mb) (set! the-apple-menu apple))) (tellv cocoa-mb setAutoenablesItems: #:type _BOOL #f) (defclass menu-bar% object% (define menus null) (define/public (enable-top pos on?) (set-box! (cddr (list-ref menus pos)) on?) (when (eq? current-mb this) (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)) setEnabled: #:type _BOOL on?))) (define/public (delete which pos) (atomically (when (eq? current-mb this) (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)))) (set! menus (let loop ([menus menus] [pos pos]) (cond [(null? menus) menus] [(zero? pos) (cdr menus)] [else (cons (car menus) (loop (cdr menus) (sub1 pos)))]))))) (public [append-menu append]) (define (append-menu menu title) (set! menus (append menus (list (list* menu title (box #t))))) (send menu set-parent this) (when (eq? current-mb this) (send menu install cocoa-mb title #t))) (define/public (install) (let loop () (when ((tell #:type _NSInteger cocoa-mb numberOfItems) . > . 1) (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)) (loop))) (for-each (lambda (menu) (send (car menu) install cocoa-mb (cadr menu) (unbox (cddr menu)))) 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 (set-label-top pos str) (set! menus (append (take menus pos) (let ([i (list-ref menus pos)]) (list (cons (car i) (cons str (cddr i))))) (drop menus (add1 pos)))) (when (eq? current-mb this) (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) setTitle: #:type _NSString (clean-menu-label str)))) (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))