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