1#lang racket/base 2(require racket/class 3 ffi/unsafe 4 ffi/unsafe/objc 5 (only-in racket/list take drop) 6 "../../syntax.rkt" 7 "../../lock.rkt" 8 "utils.rkt" 9 "types.rkt" 10 "const.rkt" 11 "queue.rkt") 12 13(provide 14 (protect-out menu-bar% 15 get-menu-bar-height 16 reset-menu-bar!)) 17 18(import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) 19 20(define-cf CFBundleGetMainBundle (_fun -> _pointer)) 21(define-cf CFBundleGetInfoDictionary (_fun _pointer -> _id)) 22 23(define app-name 24 (or 25 (let ([dict (CFBundleGetInfoDictionary (CFBundleGetMainBundle))]) 26 (and dict 27 (let ([appName (tell dict objectForKey: #:type _NSString "CFBundleName")] 28 [alt (lambda () 29 (tell #:type _NSString (tell NSProcessInfo processInfo) processName))]) 30 (if (not appName) 31 (alt) 32 (let ([appName (cast appName _id _NSString)]) 33 (if (equal? appName "") 34 (alt) 35 appName)))))) 36 "MrEd")) 37 38(define the-apple-menu #f) 39(define recurring-for-command (make-parameter #f)) 40 41(define-objc-class RacketBarMenu NSMenu 42 [] 43 ;; Disable automatic handling of keyboard shortcuts, except for 44 ;; the Apple menu 45 (-a _BOOL (performKeyEquivalent: [_id evt]) 46 (or (and the-apple-menu 47 (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) 48 ;; Explicity send the event to the keyWindow: 49 (and 50 ;; Don't go into an infinite loop: 51 (not (recurring-for-command)) 52 ;; Don't handle Cmd-` for cycling through windows: 53 ;; [Is this right for all locales?] 54 (not (equal? "`" (tell #:type _NSString evt characters))) 55 ;; Otherwise, try to dispatch to the first respnder: 56 (let ([w (tell app keyWindow)]) 57 (and w 58 (let ([r (tell w firstResponder)]) 59 (and r 60 (begin 61 (parameterize ([recurring-for-command #t]) 62 (let ([evt-type (tell #:type _NSInteger evt type)]) 63 (cond 64 [(= NSKeyDown evt-type) 65 (tell r keyDown: evt)] 66 [(= NSKeyUp evt-type) 67 (tell r keyUp: evt)]))) 68 #t))))))))) 69 70(define cocoa-mb (tell (tell RacketBarMenu alloc) init)) 71(define current-mb #f) 72 73;; Used to detect mouse click on the menu bar: 74(define (reset-menu-bar!) 75 (define screens (tell NSScreen screens)) 76 (define mb-screens 77 (if (and (version-10.9-or-later?) 78 (tell #:type _BOOL NSScreen screensHaveSeparateSpaces)) 79 (for/list ([i (in-range (tell #:type _NSUInteger screens count))]) 80 (tell screens objectAtIndex: #:type _NSUInteger i)) 81 (list (tell screens objectAtIndex: #:type _NSUInteger 0)))) 82 (define x+w+ys 83 (for/list ([screen (in-list mb-screens)]) 84 (define f (tell #:type _NSRect screen frame)) 85 (define x (NSPoint-x (NSRect-origin f))) 86 (define w (NSSize-width (NSRect-size f))) 87 (define y (+ (NSPoint-y (NSRect-origin f)) 88 (NSSize-height (NSRect-size f)))) 89 (list x w y))) 90 (set-menu-bar-hooks! 91 (lambda (p flipped?) 92 (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) 93 (for/or ([x+w+y (in-list x+w+ys)]) 94 (define x (car x+w+y)) 95 (define w (cadr x+w+y)) 96 (define y (caddr x+w+y)) 97 (and (<= x (NSPoint-x p) (+ x w)) 98 (<= (- y h) (if flipped? (- y (NSPoint-y p)) (NSPoint-y p)) y))))))) 99 100(reset-menu-bar!) 101 102;; Init menu bar 103(let ([app (tell NSApplication sharedApplication)] 104 [add-one (lambda (mb menu) 105 (let ([item (tell (tell NSMenuItem alloc) 106 initWithTitle: #:type _NSString "" 107 action: #:type _SEL #f 108 keyEquivalent: #:type _NSString "")]) 109 (tellv item setSubmenu: menu) 110 (tellv mb addItem: item) 111 (tellv item release)))]) 112 (let ([apple (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "")]) 113 (let ([std (lambda (title sel [shortcut ""] [mods #f] [delegate? #f]) 114 (let ([item (tell (tell NSMenuItem alloc) 115 initWithTitle: #:type _NSString title 116 action: #:type _SEL sel 117 keyEquivalent: #:type _NSString shortcut)]) 118 (when mods 119 (tellv item setKeyEquivalentModifierMask: #:type _NSInteger mods)) 120 (tellv item setTarget: (if delegate? 121 (tell app delegate) 122 app)) 123 (tellv apple addItem: item) 124 (tellv item release)))]) 125 (std (format "About ~a" app-name) (selector openAbout:) "" #f #t) 126 (std "Preferences..." (selector openPreferences:) "," #f #t) 127 (tellv apple addItem: (tell NSMenuItem separatorItem)) 128 (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) 129 (tellv app setServicesMenu: services) 130 (let ([item (tell (tell NSMenuItem alloc) 131 initWithTitle: #:type _NSString "Services" 132 action: #:type _SEL #f 133 keyEquivalent: #:type _NSString "")]) 134 (tellv item setSubmenu: services) 135 (tellv apple addItem: item) 136 (tellv item release))) 137 (tellv apple addItem: (tell NSMenuItem separatorItem)) 138 (std (format "Hide ~a" app-name) (selector hide:) "h") 139 (std "Hide Others" (selector hideOtherApplications:) "h" (bitwise-ior 140 NSAlternateKeyMask 141 NSCommandKeyMask)) 142 (std "Show All" (selector unhideAllApplications:)) 143 (tellv apple addItem: (tell NSMenuItem separatorItem)) 144 (std (format "Quit ~a" app-name) (selector terminate:) "q")) 145 (add-one cocoa-mb apple) 146 (tellv app setAppleMenu: apple) 147 (tellv apple release) 148 (tellv app setMainMenu: cocoa-mb) 149 (set! the-apple-menu apple))) 150 151(tellv cocoa-mb setAutoenablesItems: #:type _BOOL #f) 152 153(defclass menu-bar% object% 154 (define menus null) 155 156 (define/public (enable-top pos on?) 157 (set-box! (cddr (list-ref menus pos)) on?) 158 (when (eq? current-mb this) 159 (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)) 160 setEnabled: #:type _BOOL on?))) 161 162 (define/public (delete which pos) 163 (atomically 164 (when (eq? current-mb this) 165 (tellv cocoa-mb removeItem: 166 (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)))) 167 (set! menus (let loop ([menus menus] 168 [pos pos]) 169 (cond 170 [(null? menus) menus] 171 [(zero? pos) (cdr menus)] 172 [else (cons (car menus) 173 (loop (cdr menus) 174 (sub1 pos)))]))))) 175 176 (public [append-menu append]) 177 (define (append-menu menu title) 178 (set! menus (append menus (list (list* menu title (box #t))))) 179 (send menu set-parent this) 180 (when (eq? current-mb this) 181 (send menu install cocoa-mb title #t))) 182 183 (define/public (install) 184 (let loop () 185 (when ((tell #:type _NSInteger cocoa-mb numberOfItems) . > . 1) 186 (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)) 187 (loop))) 188 (for-each (lambda (menu) 189 (send (car menu) install cocoa-mb (cadr menu) (unbox (cddr menu)))) 190 menus) 191 (set! current-mb this)) 192 193 (define top-wx #f) 194 (define/public (set-top-window top) 195 (set! top-wx top)) 196 (define/public (get-top-window) 197 top-wx) 198 199 (define/public (set-label-top pos str) 200 (set! menus (append 201 (take menus pos) 202 (let ([i (list-ref menus pos)]) 203 (list (cons (car i) (cons str (cddr i))))) 204 (drop menus (add1 pos)))) 205 (when (eq? current-mb this) 206 (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) 207 setTitle: #:type _NSString (clean-menu-label str)))) 208 209 (define/public (do-on-menu-click) 210 (let ([es (send top-wx get-eventspace)]) 211 (when es 212 (queue-event es (lambda () 213 (send top-wx on-menu-click)))))) 214 215 (super-new)) 216 217(define initial-menubar-height 218 (inexact->exact (floor (tell #:type _CGFloat cocoa-mb menuBarHeight)))) 219 220(define (get-menu-bar-height) 221 initial-menubar-height) 222