1#lang racket/base
2(require ffi/unsafe/objc
3         ffi/unsafe
4         racket/class
5         "queue.rkt"
6         "utils.rkt"
7         "const.rkt"
8         "types.rkt"
9         "keycode.rkt"
10         "pool.rkt"
11         "cursor.rkt"
12         "key-translate.rkt"
13         "../common/local.rkt"
14         "../../lock.rkt"
15         "../common/event.rkt"
16         "../common/queue.rkt"
17         "../common/delay.rkt"
18         "../../syntax.rkt"
19         "../common/freeze.rkt")
20
21(provide
22 (protect-out window%
23
24              FocusResponder
25              KeyMouseResponder
26              KeyMouseTextResponder
27              CursorDisplayer
28
29              queue-window-event
30              queue-window-refresh-event
31              queue-window*-event
32              request-flush-delay
33              cancel-flush-delay
34              make-init-point
35              flush-display
36
37              special-control-key
38              special-option-key))
39
40(define-local-member-name flip-client)
41
42;; ----------------------------------------
43
44(define special-control-key? #f)
45(define special-control-key
46  (case-lambda
47   [() special-control-key?]
48   [(on?) (set! special-control-key? (and on? #t))]))
49
50(define special-option-key? #f)
51(define special-option-key
52  (case-lambda
53   [() special-option-key?]
54   [(on?) (set! special-option-key? (and on? #t))]))
55
56;; ----------------------------------------
57
58(define-objc-mixin (FocusResponder Superclass)
59  [wxb]
60  [-a _BOOL (acceptsFirstResponder)
61      (let ([wx (->wx wxb)])
62        (or (not wx)
63            (send wx can-be-responder?)))]
64  [-a _BOOL (becomeFirstResponder)
65      (and (super-tell becomeFirstResponder)
66           (let ([wx (->wx wxb)])
67             (when wx (send wx is-responder wx #t))
68             #t))]
69  [-a _BOOL (resignFirstResponder)
70      (and (super-tell resignFirstResponder)
71           (let ([wx (->wx wxb)])
72             (when wx
73               (send wx is-responder wx #f)
74               (send wx set-saved-marked #f #f))
75             #t))]
76  [-a _void (changeColor: [_id sender])
77      (let ([wx (->wx wxb)])
78        (when wx (send wx on-color-change)))])
79
80(import-class NSArray NSPanel NSTextView)
81(import-protocol NSTextInput)
82
83(define current-insert-text (make-parameter #f))
84(define current-insert-text-timestamp (make-parameter 0.0))
85(define current-set-mark (make-parameter #f))
86
87(define NSDragOperationCopy 1)
88
89(import-class NSAttributedString)
90(define _NSStringOrAttributed
91  (make-ctype _id
92              (lambda (v)
93                (cast v _NSString _id))
94              (lambda (v)
95                (if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class))
96                    (tell #:type _NSString v string)
97                    (cast v _id _NSString)))))
98
99(define-objc-mixin (KeyMouseResponder Superclass)
100  [wxb]
101  [-a _void (mouseDown: [_id event])
102      (unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down)
103        (super-tell #:type _void mouseDown: event)
104        (let ([wx (->wx wxb)])
105         (when wx
106           (send wx post-mouse-down))))]
107  [-a _void (mouseUp: [_id event])
108      (unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up)
109        (super-tell #:type _void mouseUp: event))]
110  [-a _void (mouseDragged: [_id event])
111      (unless (do-mouse-event wxb event 'motion #t #f #f)
112        (super-tell #:type _void mouseDragged: event))]
113  [-a _void (mouseMoved: [_id event])
114      ;; This event is sent to the first responder, instead of the
115      ;; view under the mouse.
116      (let* ([win (tell event window)]
117             [view (and win (tell win contentView))]
118             [hit (and view (tell view hitTest: #:type _NSPoint
119                                  (tell #:type _NSPoint event locationInWindow)))])
120        (let loop ([hit hit])
121          (when hit
122            (if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:))
123                (unless (tell #:type _BOOL hit doMouseMoved: event)
124                  (super-tell #:type _void mouseMoved: event))
125                (loop (tell hit superview))))))]
126  [-a _BOOL (doMouseMoved: [_id event])
127      ;; called by mouseMoved:
128      (and
129       ;; Make sure we're in the right eventspace:
130       (let ([wx (->wx wxb)])
131         (and wx
132              (eq? (current-thread)
133                   (eventspace-handler-thread
134                    (send wx get-eventspace)))))
135       ;; Right event space, so handle the event:
136       (do-mouse-event wxb event 'motion #f #f #f))]
137  [-a _void (mouseEntered: [_id event])
138      (unless (do-mouse-event wxb event 'enter 'check 'check 'check)
139        (super-tell #:type _void mouseEntered: event))]
140  [-a _void (mouseExited: [_id event])
141      (unless (do-mouse-event wxb event 'leave 'check 'check 'check)
142        (super-tell #:type _void mouseExited: event))]
143  [-a _void (rightMouseDown: [_id event])
144      (unless (do-mouse-event wxb event 'right-down #f #f #t)
145        (super-tell #:type _void rightMouseDown: event))]
146  [-a _void (rightMouseUp: [_id event])
147      (unless (do-mouse-event wxb event 'right-up #f #f #f)
148        (super-tell #:type _void rightMouseUp: event))]
149  [-a _void (rightMouseDragged: [_id event])
150      (unless (do-mouse-event wxb event 'motion #f #f #t)
151        (super-tell #:type _void rightMouseDragged: event))]
152  [-a _void (otherMouseDown: [_id event])
153      (unless (do-mouse-event wxb event 'middle-down #f #t #f)
154        (super-tell #:type _void otherMouseDown: event))]
155  [-a _void (otherMouseUp: [_id event])
156      (unless (do-mouse-event wxb event 'middle-up #f #f #f)
157        (super-tell #:type _void otherMouseUp: event))]
158  [-a _void (otherMouseDragged: [_id event])
159      (unless (do-mouse-event wxb event 'motion #f #t #f)
160        (super-tell #:type _void otherMouseDragged: event))]
161
162  [-a _void (scrollWheel: [_id event])
163      (unless (do-wheel-event wxb event self)
164        (super-tell #:type _void scrollWheel: event))]
165
166  [-a _void (keyDown: [_id event])
167      (unless (do-key-event wxb event self #t #f #f 0.0 0.0)
168        (super-tell #:type _void keyDown: event))]
169  [-a _void (keyUp: [_id event])
170      (unless (do-key-event wxb event self #f #f #f 0.0 0.0)
171        (super-tell #:type _void keyUp: event))]
172  [-a _void (flagsChanged: [_id event])
173      (unless (do-key-event wxb event self #f #t #f 0.0 0.0)
174        (super-tell #:type _void flagsChanged: event))]
175  [-a _void (insertText: [_NSStringOrAttributed str])
176      (set-saved-marked! wxb #f #f)
177      (let ([cit (current-insert-text)])
178        (if cit
179            (set-box! cit (if (unbox cit)
180                              (string-append (unbox cit) str)
181                              str))
182            (let ([wx (->wx wxb)])
183              (post-dummy-event) ;; to wake up in case of character palette insert
184              (when wx
185                (let ([ts (current-insert-text-timestamp)])
186                  (queue-window-event wx (lambda ()
187                                           (send wx key-event-as-string str ts))))))))]
188
189  ;; for NSTextInput:
190  [-a _BOOL (hasMarkedText) (get-saved-marked wxb)]
191  [-a _id (validAttributesForMarkedText)
192      (tell NSArray array)]
193  [-a _void (unmarkText)
194      (set-saved-marked! wxb #f #f)]
195  [-a _NSRange (markedRange)
196      (let ([saved-marked (get-saved-marked wxb)])
197        (make-NSRange 0 (if saved-marked (string-length saved-marked) 0)))]
198  [-a _NSRange (selectedRange)
199      (or (let ([s (get-saved-selected wxb)])
200            (and s
201                 (make-NSRange (car s) (cdr s))))
202          (make-NSRange 0 0))]
203  [-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange])
204      ;; We interpreter a call to `setMarkedText:' as meaning that the
205      ;; key is a dead key for composing some other character.
206      (let ([m (current-set-mark)]) (when m (set-box! m #t)))
207      ;; At the same time, we need to remember the text:
208      (set-saved-marked! wxb aString (cons (NSRange-location selRange)
209                                           (NSRange-length selRange)))
210      (void)]
211  [-a _id (validAttributesForMarkedText) #f]
212  [-a _id (attributedSubstringFromRange: [_NSRange theRange])
213      (let ([saved-marked (get-saved-marked wxb)])
214        (and saved-marked
215             (let ([s (tell (tell NSAttributedString alloc)
216                            initWithString: #:type _NSString
217                            (range-substring saved-marked theRange))])
218               (tellv s autorelease)
219               s)))]
220
221  [-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0]
222  [-a _NSInteger (conversationIdentifier) 0]
223  [-a _void (doCommandBySelector: [_SEL aSelector]) (void)]
224  [-a _NSRect (firstRectForCharacterRange: [_NSRange r])
225      ;; This location is used to place a window for multi-character
226      ;; input, such as when typing Chinese with Pinyin
227      (let ([f (tell #:type _NSRect self frame)]
228            [pt (tell #:type _NSPoint (tell self window)
229                      convertBaseToScreen:
230                      #:type _NSPoint
231                      (tell #:type _NSPoint self
232                            convertPoint: #:type _NSPoint
233                            (make-NSPoint 0 0)
234                            toView: #f))])
235        (make-NSRect pt (NSRect-size f)))]
236
237  ;; Dragging:
238  [-a _int (draggingEntered: [_id info])
239      NSDragOperationCopy]
240  [-a _BOOL (prepareForDragOperation: [_id info])
241      #t]
242  [-a _BOOL (performDragOperation: [_id info])
243      (let ([wx (->wx wxb)])
244        (when wx
245          (with-autorelease
246           (let ([pb (tell info draggingPasteboard)])
247             (let ([data (tell pb propertyListForType: NSFilenamesPboardType)])
248               (when data
249                 (for ([i (in-range (tell #:type _NSUInteger data count))])
250                   (let ([s (tell #:type _NSString data objectAtIndex: #:type _NSUInteger i)])
251                     (queue-window-event wx
252                                         (lambda ()
253                                           (send wx do-on-drop-file s)))))))))))
254      #t])
255(define (set-saved-marked! wxb str sel)
256  (let ([wx (->wx wxb)])
257    (when wx
258      (send wx set-saved-marked str sel))))
259(define (get-saved-marked wxb)
260  (let ([wx (->wx wxb)])
261    (and wx
262         (send wx get-saved-marked))))
263(define (get-saved-selected wxb)
264  (let ([wx (->wx wxb)])
265    (and wx
266         (send wx get-saved-selected))))
267(define (range-substring s range)
268  (let ([start (min (max 0 (NSRange-location range)) (string-length s))])
269    (substring s start (max (+ start (NSRange-length range))
270                            (string-length s)))))
271
272(define-objc-class InputMethodPanel NSPanel
273  []
274  [-a _BOOL (canBecomeKeyWindow) #f]
275  [-a _BOOL (canBecomeMainWindow) #f]
276  [-a _void (windowDidResize: [_id notification])
277      (reset-input-method-window-size)])
278
279(define-objc-mixin (KeyMouseTextResponder Superclass)
280  #:mixins (KeyMouseResponder)
281  #:protocols (NSTextInput)
282  [wxb])
283
284(define-objc-mixin (CursorDisplayer Superclass)
285  [wxb]
286  [-a _void (resetCursorRects)
287      (let ([wx (->wx wxb)])
288        (when wx
289          (send wx reset-cursor-rects)))])
290
291(define dead-key-state (make-initial-dead-key-state))
292
293(define << arithmetic-shift)
294
295(define _ptr-to-id (_ptr i _id))
296
297(define (do-key-event wxb event self down? mod-change? wheel wheel-x-steps wheel-y-steps)
298  (define type (tell #:type _ushort event type))
299  (define key-down? (= (bitwise-and type #b1111) NSKeyDown))
300  (let ([wx (->wx wxb)])
301    (and
302     wx
303     (let ([inserted-text (box #f)]
304           [set-mark (box #f)]
305           [had-saved-text? (and (send wx get-saved-marked) #t)])
306       (when down?
307         ;; Calling `interpretKeyEvents:' allows key combinations to be
308         ;; handled, such as option-e followed by e to produce é. The
309         ;; call to `interpretKeyEvents:' typically calls `insertText:',
310         ;; so we set `current-insert-text' to tell `insertText:' to just
311         ;; give us back the text in the parameter. For now, we ignore the
312         ;; text and handle the event as usual, though probably we should
313         ;; be doing something with it.
314         (parameterize ([current-insert-text inserted-text]
315                        [current-insert-text-timestamp (tell #:type _double event timestamp)]
316                        [current-set-mark set-mark])
317           (let ([array (tell (tell NSArray alloc)
318                              initWithObjects: #:type _ptr-to-id event
319                              count: #:type _NSUInteger 1)])
320             (tellv self interpretKeyEvents: array)
321             (tellv array release))))
322       (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
323              [bit? (lambda (m b) (positive? (bitwise-and m b)))]
324              [pos (tell #:type _NSPoint event locationInWindow)]
325              [str (cond
326                    [wheel #f]
327                    [mod-change? #f]
328                    [(unbox set-mark) ""] ; => dead key for composing characters
329                    [(unbox inserted-text)]
330                    [else
331                     (tell #:type _NSString event characters)])]
332              [prev-dks (and key-down?
333                             ;; We may need the key state before
334                             ;; decoding to trry alternative modifiers
335                             (copy-dead-key-state dead-key-state))]
336              [dead-key? (unbox set-mark)]
337              [control? (bit? modifiers NSControlKeyMask)]
338              [option?  (bit? modifiers NSAlternateKeyMask)]
339	      [shift?   (bit? modifiers NSShiftKeyMask)]
340              [cmd?     (bit? modifiers NSCommandKeyMask)]
341              [caps?    (bit? modifiers NSAlphaShiftKeyMask)]
342              [codes (cond
343                      [wheel wheel]
344                      [mod-change? (case (tell #:type _ushort event keyCode)
345                                     [(56) '(shift)]
346                                     [(59) '(control)]
347                                     [(60) '(rshift)]
348                                     [(62) '(rcontrol)]
349                                     [else '()])]
350                      [had-saved-text? str]
351                      [(map-key-code (tell #:type _ushort event keyCode))
352                       => list]
353                      [(string=? "" str) '(#\nul)]
354                      [(and (= 1 (string-length str))
355                            (let ([c (string-ref str 0)])
356                              (or (and control?
357                                       (char<=? #\u00 c #\u1F)
358                                       (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
359                                         (and (string? alt-str)
360                                              (= 1 (string-length alt-str))
361                                              (string-ref alt-str 0)))))))
362                       => list]
363                      [else str])])
364         (for/fold ([result dead-key?]) ([one-code codes]
365                                         [code-offset (in-naturals)])
366           (or
367            ;; Handle one key event
368            (let-values ([(x y) (send wx window-point-to-view pos)])
369              (let ([k (new key-event%
370                            [key-code one-code]
371                            [shift-down shift?]
372                            [control-down control?]
373                            [meta-down cmd?]
374                            [alt-down option?]
375                            [x (->long x)]
376                            [y (->long y)]
377                            [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
378                            [caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
379                (when (or (eq? one-code 'wheel-up)
380                          (eq? one-code 'wheel-down))
381                  (send k set-wheel-steps wheel-y-steps))
382                (when (or (eq? one-code 'wheel-left)
383                          (eq? one-code 'wheel-right))
384                  (send k set-wheel-steps wheel-x-steps))
385                (unless (or wheel mod-change?)
386                  (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
387                    (when (and (string? alt-str)
388                               (= 1 (string-length alt-str)))
389                      (let ([alt-code (string-ref alt-str 0)])
390                        (unless (equal? alt-code (send k get-key-code))
391                          (send k set-other-altgr-key-code alt-code)))))
392                  (when key-down?
393                    (let ()
394		      (define (toggle flag m b) (if flag (- m b) (+ m b)))
395		      (define (old-dks-copy) (copy-dead-key-state prev-dks))
396                      (define mask 	     (+ modifier-shift-key modifier-option-key modifier-alpha-lock
397						modifier-cmd-key modifier-control-key))
398      		      (define kc             (tell #:type _ushort event keyCode))
399                      (define mods           (bitwise-and (<< modifiers -8) mask))
400                      (when (zero? code-offset)<
401                        (define s              (key-translate kc #:modifier-key-state mods
402                                                              #:dead-key-state dead-key-state))
403                        (define dead?          (= 0 (string-length s)))
404                        (unless dead?          (set! dead-key-state (make-initial-dead-key-state))))
405		      ;; the other codes all assume that caps-lock is off, so make sure it is turned off
406		      (set!   mods            (if caps? (toggle caps? mods modifier-alpha-lock) mods))
407                      (define shift-mod       (toggle shift?   mods modifier-shift-key))
408                      (define alt-mod         (toggle option?  mods modifier-option-key))
409                      (define shift-alt-mod   (toggle shift? (toggle option?  mods modifier-option-key)
410						      modifier-shift-key))
411		      ;; (define cmd-mod   (toggle cmd?     mods modifier-cmd-key))
412		      ;; (define ctrl-mod  (toggle control? mods modifier-control-key))
413		      (define (alternative who setter mod)
414			(define s (key-translate kc #:modifier-key-state mod #:dead-key-state (old-dks-copy)))
415			(setter (and (> (string-length s) code-offset) (string-ref s code-offset)))
416			(void))
417		      (alternative 'shift     (lambda (c) (send k set-other-shift-key-code c))           shift-mod)
418		      (alternative 'alt       (lambda (c) (send k set-other-altgr-key-code c))             alt-mod)
419		      ;; what exacly is shift+altgr supposed to hold ?
420		      (alternative 'shift-alt (lambda (c) (send k set-other-shift-altgr-key-code c)) shift-alt-mod)))
421
422                  ;; If the Option key is disabled globally via
423                  ;; `special-option-key`, then swap the Option and
424                  ;; non-Option results when Option is pressed.
425                  (when (and option?
426                             special-option-key?
427                             (send k get-other-altgr-key-code))
428                    (let ([other (send k get-other-altgr-key-code)])
429                      (send k set-other-altgr-key-code (send k get-key-code))
430                      (send k set-key-code other)))
431                  ;; When a Ctl- combination produces
432                  ;; no key (such as with Ctl-space), it works ok to
433                  ;; use the mapping produced with Shift also down.
434                  (when (and control?
435                             (equal? (send k get-key-code) #\u00)
436                             (send k get-other-shift-key-code))
437                    (send k set-key-code (send k get-other-shift-key-code))))
438                (unless wheel
439                  (unless (or down? (and mod-change?
440                                         (case (send k get-key-code)
441                                           [(shift rshift) (send k get-shift-down)]
442                                           [(control rcontrol) (send k get-control-down)]
443                                           [else #t])))
444                    ;; swap altenate with main
445                    (send k set-key-release-code (send k get-key-code))
446                    (send k set-key-code 'release)))
447                (if (send wx definitely-wants-event? k)
448                    (begin
449                      (queue-window-event wx (lambda ()
450                                               (send wx dispatch-on-char/sync k)))
451                      #t)
452                    (constrained-reply (send wx get-eventspace)
453                                       (lambda () (send wx dispatch-on-char k #t))
454                                       #t))))
455            result)))))))
456
457(define (do-wheel-event wxb event self)
458  (define wx (->wx wxb))
459  (cond
460    [(not wx) #f]
461    [else
462     (define-values (leftover-y leftover-x mode)
463       (send wx get-wheel-state))
464
465     (let loop ([handled? #t]
466                [delta-y (+ (if (version-10.7-or-later?)
467                                (* (tell #:type _CGFloat event scrollingDeltaY)
468                                   (if (tell #:type _BOOL event hasPreciseScrollingDeltas)
469                                       1
470                                       WHEEL-STEP-AMT))
471                                (tell #:type _CGFloat event deltaY))
472                            leftover-y)]
473                [delta-x (+ (if (version-10.7-or-later?)
474                                (* (tell #:type _CGFloat event scrollingDeltaX)
475                                   (if (tell #:type _BOOL event hasPreciseScrollingDeltas)
476                                       1
477                                       WHEEL-STEP-AMT))
478                                (tell #:type _CGFloat event deltaX))
479                            leftover-x)])
480       (cond
481         ;; If we've tried to do-key-event once and it returned #f,
482         ;; meaning it can't find a target for the event, then we need
483         ;; to bubble up immediately without saving the wheel state.
484         [(not handled?) #f]
485
486         [(and ((abs delta-y) . < . WHEEL-STEP-AMT)
487               ((abs delta-x) . < . WHEEL-STEP-AMT))
488          (begin0 #t
489            (send wx set-wheel-state delta-y delta-x))]
490
491         [else
492          (define y-steps (case mode
493                            [(fraction)
494                             (/ (abs delta-y) WHEEL-STEP-AMT)]
495                            [(integer)
496                             (truncate (/ (abs delta-y) WHEEL-STEP-AMT))]
497                            [else
498                             (if ((abs delta-y) . < . WHEEL-STEP-AMT)
499                                 0.0
500                                 1.0)]))
501
502          (define x-steps (case mode
503                            [(fraction)
504                             (/ (abs delta-x) WHEEL-STEP-AMT)]
505                            [(integer)
506                             (truncate (/ (abs delta-x) WHEEL-STEP-AMT))]
507                            [else (if ((abs delta-x) . < . WHEEL-STEP-AMT)
508                                      0.0
509                                      1.0)]))
510
511          (define evts (append (cond
512                                 [(zero? y-steps) '()]
513                                 [(positive? delta-y) '(wheel-up)]
514                                 [else '(wheel-down)])
515                               (cond
516                                 [(zero? x-steps) '()]
517                                 [(positive? delta-x) '(wheel-left)]
518                                 [else '(wheel-right)])))
519
520          (define new-handled?
521            (if (pair? evts)
522                (do-key-event wxb event self #f #f evts x-steps y-steps)
523                handled?))
524
525          (if (eq? mode 'fraction)
526              (loop new-handled? 0.0 0.0)
527              (loop new-handled?
528                    (cond
529                      [(delta-y . < . 0.0)
530                       (+ delta-y (* WHEEL-STEP-AMT y-steps))]
531                      [else
532                       (- delta-y (* WHEEL-STEP-AMT y-steps))])
533                    (cond
534                      [(delta-x . < . 0.0)
535                       (+ delta-x (* WHEEL-STEP-AMT x-steps))]
536                      [else
537                       (- delta-x (* WHEEL-STEP-AMT x-steps))])))]))]))
538
539(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind])
540  (let ([wx (->wx wxb)])
541    (and
542     wx
543     (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
544            [bit? (lambda (m b) (positive? (bitwise-and m b)))]
545            [pos (tell #:type _NSPoint event locationInWindow)])
546       (let-values ([(x y) (send wx window-point-to-view pos)]
547                    [(control-down) (bit? modifiers NSControlKeyMask)]
548                    [(l?) (if (eq? l? 'check)
549                              (send wx get-last-left-button)
550                              l?)]
551                    [(m?) (if (eq? m? 'check)
552                              (send wx get-last-middle-button)
553                              m?)]
554                    [(r?) (if (eq? r? 'check)
555                              (send wx get-last-right-button)
556                              r?)])
557         (let ([l? (and l? (not control-down))]
558               [r? (or r? (and l? control-down))])
559           (send wx set-last-buttons l? m? r?)
560           (let ([m (new mouse-event%
561                         [event-type (if control-down ctl-kind kind)]
562                         [left-down l?]
563                         [middle-down m?]
564                         [right-down r?]
565                         [x (->long x)]
566                         [y (->long y)]
567                         [shift-down (bit? modifiers NSShiftKeyMask)]
568                         [meta-down (bit? modifiers NSCommandKeyMask)]
569                         [alt-down (bit? modifiers NSAlternateKeyMask)]
570                         [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
571                         [caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
572             (cond
573              [(send m dragging?) (void)]
574              [(send m button-down?)
575               (send wx set-sticky-cursor)
576               (send wx start-no-cursor-rects)]
577              [(or l? m? r?) (void)]
578              [else (send wx end-no-cursor-rects)])
579             (if (send wx definitely-wants-event? m)
580                 (begin
581                   (queue-window-event wx (lambda ()
582                                            (send wx dispatch-on-event/sync m)))
583                   #t)
584                 (constrained-reply (send wx get-eventspace)
585                                    (lambda () (send wx dispatch-on-event m #t))
586                                    #t)))))))))
587
588(define-cocoa NSFilenamesPboardType _id)
589
590(define _CGError _int32)
591(define-appserv CGWarpMouseCursorPosition (_fun _NSPoint -> _CGError))
592(define-appserv CGAssociateMouseAndMouseCursorPosition (_fun _BOOL -> _CGError))
593
594(define window%
595  (class object%
596    (init-field parent
597                cocoa
598                [no-show? #f])
599
600    (define is-on? #f)
601    (define accept-drag? #f)
602    (define accept-parent-drag? #f)
603
604    (super-new)
605
606    (queue-autorelease-flush)
607
608    (define eventspace (if parent
609                           (send parent get-eventspace)
610                           (current-eventspace)))
611
612    (when (eventspace-shutdown? eventspace)
613      (error '|GUI object initialization| "the eventspace has been shutdown"))
614
615    (set-ivar! cocoa wxb (->wxb this))
616
617    (unless no-show?
618      (show #t))
619
620    (define/public (focus-is-on on?)
621      (void))
622
623    (define is-responder? #f)
624
625    (define/public (is-responder wx on?)
626      (unless (eq? on? is-responder?)
627        (set! is-responder? (and on? #t))
628        (send parent is-responder wx on?)))
629
630    (define/public (hide-children)
631      (is-responder this #f)
632      (focus-is-on #f))
633    (define/public (show-children)
634      (void))
635    (define/public (fixup-locations-children)
636      (void))
637    (define/public (fix-dc)
638      (void))
639    (define/public (paint-children)
640      (void))
641
642    (define/public (get-cocoa) cocoa)
643    (define/public (get-cocoa-content) cocoa)
644    (define/public (get-cocoa-focus) (get-cocoa-content))
645    (define/public (get-cocoa-cursor-content) (get-cocoa-content))
646    (define/public (get-cocoa-window) (send parent get-cocoa-window))
647    (define/public (get-wx-window) (send parent get-wx-window))
648
649    (define/public (get-dialog-level)
650      ;; called in event-pump thread
651      (send parent get-dialog-level))
652
653    (define/public (make-graphics-context)
654      (and parent
655           (send parent make-graphics-context)))
656
657    (define/public (get-parent)
658      parent)
659
660    (define/public (set-parent p)
661      (set! parent p))
662
663    (define/public (get-eventspace) eventspace)
664
665    (define/public (show on?)
666      (atomically
667       (unless (eq? (and on? #t) is-on?)
668         (if on?
669             (tellv (send parent get-cocoa-content) addSubview: cocoa)
670             (with-autorelease
671              (tellv cocoa removeFromSuperview)))
672         (set! is-on? (and on? #t))
673         (maybe-register-as-child parent on?)
674         (if on?
675             (show-children)
676             (begin
677               (hide-children)
678               (is-responder this #f))))))
679    (define/public (maybe-register-as-child parent on?)
680      ;; override this to call register-as-child if the window
681      ;; can have the focus or otherwise needs show-state notifications.
682      (void))
683    (define/public (register-as-child parent on?)
684      (send parent register-child this on?))
685    (define/public (register-child child on?)
686      (void))
687
688    (define/public (on-new-child child on?)
689      (if on?
690          (queue-window-event
691           child
692           (lambda ()
693             (atomically
694              (with-autorelease
695               (send child child-accept-drag (or accept-drag? accept-parent-drag?))))))
696          (send child child-accept-drag #f)))
697
698    (define/public (is-shown?)
699      (and (tell cocoa superview) #t))
700
701    (define/public (is-shown-to-root?)
702      (and (is-shown?)
703           (send parent is-shown-to-root?)))
704
705    (define/public (is-shown-to-before-root?)
706      (and (is-shown?)
707           (send parent is-shown-to-before-root?)))
708
709    (define enabled? #t)
710    (define/public (is-enabled-to-root?)
711      (and (is-window-enabled?/raw) (is-parent-enabled-to-root?)))
712    (define/public (is-parent-enabled-to-root?)
713      (send parent is-enabled-to-root?))
714    (define/public (is-window-enabled?/raw)
715      enabled?)
716    (define/public (is-window-enabled?)
717      (is-window-enabled?/raw))
718    (define/public (enable on?)
719      (atomically
720       (set! enabled? on?)
721       (when (is-parent-enabled-to-root?)
722         (enable-window on?))))
723    (define/public (enable-window on?)
724      ;; in atomic mode
725      (void))
726
727    (define skip-enter-leave? #f)
728    (define/public (skip-enter-leave-events skip?)
729      (set! skip-enter-leave? skip?))
730
731    (define block-all-mouse-events? #f)
732    (define/public (block-mouse-events block?)
733      (set! block-all-mouse-events? block?))
734
735    (define/private (get-frame)
736      (let ([v (tell #:type _NSRect cocoa frame)])
737        v))
738
739    (define/public (flip y h)
740      (if parent
741          (let ([b (tell #:type _NSRect (send parent get-cocoa-content) bounds)])
742            (- (NSSize-height (NSRect-size b)) (+ y h)))
743          y))
744
745    (define/public (flip-client y)
746      (if (tell #:type _BOOL (get-cocoa-content) isFlipped)
747          y
748          (let ([r (tell #:type _NSRect (get-cocoa-content) bounds)])
749            (- (NSSize-height (NSRect-size r))
750               (- y (client-y-offset))))))
751    (define/public (client-y-offset) 0)
752
753    (define event-position-wrt-wx #f)
754    (define/public (set-event-positions-wrt wx)
755      (set! event-position-wrt-wx wx))
756
757    (define/public (is-view?) #t)
758    (define/public (window-point-to-view pos)
759      (let ([pos (if (is-view?)
760                     (tell #:type _NSPoint (get-cocoa-content)
761                           convertPoint: #:type _NSPoint pos
762                           fromView: #f)
763                     pos)])
764        (define x (NSPoint-x pos))
765        (define y (flip-client (NSPoint-y pos)))
766        (cond
767         [event-position-wrt-wx
768          (define xb (box (->long x)))
769          (define yb (box (->long y)))
770          (internal-client-to-screen xb yb)
771          (send event-position-wrt-wx internal-screen-to-client xb yb)
772          (values (unbox xb) (unbox yb))]
773         [else (values x y)])))
774
775
776    (define/public (get-x)
777      (->long (NSPoint-x (NSRect-origin (get-frame)))))
778    (define/public (get-y)
779      (let ([r (get-frame)])
780        (->long (flip (NSPoint-y (NSRect-origin r))
781                      (NSSize-height (NSRect-size r))))))
782    (define/public (get-width)
783      (->long (ceiling (NSSize-width (NSRect-size (get-frame))))))
784    (define/public (get-height)
785      (->long (ceiling (NSSize-height (NSRect-size (get-frame))))))
786    (define/public (get-position x y)
787      (let* ([r (get-frame)]
788             [p (NSRect-origin r)])
789        (set-box! x (->long (NSPoint-x p)))
790        (set-box! y (->long (flip (NSPoint-y p) (NSSize-height (NSRect-size r)))))))
791    (define/public (get-size w h)
792      (let ([s (NSRect-size (get-frame))])
793        (set-box! w (->long (ceiling (NSSize-width s))))
794        (set-box! h (->long (ceiling (NSSize-height s))))))
795
796    (define/public (get-client-size w h)
797      ;; May be called in Cocoa event-handling mode
798      (let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))])
799        (set-box! w (->long (ceiling (NSSize-width s))))
800        (set-box! h (->long (ceiling (NSSize-height s))))))
801
802    (define/public (set-size x y w h)
803      (let ([x (if (not x) (get-x) x)]
804            [y (if (not y) (get-y) y)])
805        ;; old location will need refresh:
806        (tellv cocoa setNeedsDisplay: #:type _BOOL #t)
807        (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h))
808                                                           (make-NSSize w h)))
809        ;; new location needs refresh:
810        (tellv cocoa setNeedsDisplay: #:type _BOOL #t))
811      (queue-on-size))
812
813    (define/public (internal-move x y)
814      (set-size x y (get-width) (get-height)))
815    (define/public (move x y)
816      (internal-move x y))
817
818    (define/public (on-drop-file f) (void))
819    (define/public (do-on-drop-file f)
820      (if accept-drag?
821          (on-drop-file (string->path f))
822          (when parent
823            (send parent do-on-drop-file f))))
824
825    (define/public (drag-accept-files on?)
826      (unless (eq? (and on? #t) accept-drag?)
827        (atomically
828         (with-autorelease
829          (set! accept-drag? (and on? #t))
830          (accept-drags-everywhere (or accept-drag? accept-parent-drag?))))))
831
832    (define/public (accept-drags-everywhere on?)
833      (if on?
834          (tellv (get-cocoa-content) registerForDraggedTypes:
835                 (let ([a (tell NSArray arrayWithObjects: #:type (_list i _id) (list NSFilenamesPboardType)
836                                count: #:type _NSUInteger 1)])
837                   a))
838          (tellv (get-cocoa-content) unregisterDraggedTypes))
839      (children-accept-drag on?))
840
841    (define/public (children-accept-drag on?)
842      (void))
843    (define/public (child-accept-drag on?)
844      (unless (eq? (and on? #t) accept-parent-drag?)
845        (set! accept-parent-drag? (and on? #t))
846        (accept-drags-everywhere (or accept-drag? accept-parent-drag?))))
847
848    (define/public (set-focus)
849      (when (and (can-accept-focus?)
850                 (is-enabled-to-root?))
851        (let ([w (tell cocoa window)])
852          (when w
853            (tellv w makeFirstResponder: (get-cocoa-focus))
854            ;; Within a floating frame or when potentially taking
855            ;; focus from a floating frame, also make the frame the
856            ;; key window:
857            (let ([top (get-wx-window)])
858              (when (and (or (send top floating?)
859                             (tell #:type _BOOL w isMainWindow))
860                         (tell #:type _BOOL w isVisible))
861                (tellv w makeKeyAndOrderFront: #f)))))))
862
863    (define/public (on-set-focus) (void))
864    (define/public (on-kill-focus) (void))
865
866    (define/public (definitely-wants-event? e)
867      ;; Called in Cocoa event-handling mode
868      #f)
869
870    (define/private (pre-event-refresh key?)
871      ;; Since we break the connection between the
872      ;; Cocoa queue and event handling, we
873      ;; re-sync the display in case a stream of
874      ;; events (e.g., key repeat) have a corresponding
875      ;; stream of screen updates.
876      (try-to-sync-refresh)
877      (flush))
878
879    (define/public (flush)
880      (let ([cocoa-win (get-cocoa-window)])
881        (when cocoa-win
882          (tellv cocoa-win displayIfNeeded)
883          (tellv cocoa-win flushWindowIfNeeded)
884          (when (version-10.14-or-later?)
885            (try-to-flush)))))
886
887    (define/public (dispatch-on-char/sync e)
888      (pre-event-refresh #t)
889      (dispatch-on-char e #f))
890    (define/public (dispatch-on-char e just-pre?)
891      (cond
892       [(other-modal? this) #t]
893       [(call-pre-on-char this e) #t]
894       [just-pre? #f]
895       [else (when enabled? (on-char e)) #t]))
896
897    (define/public (dispatch-on-event/sync e)
898      (pre-event-refresh #f)
899      (dispatch-on-event e #f))
900    (define/public (dispatch-on-event e just-pre?)
901      (cond
902       [(other-modal? this e) #t]
903       [(call-pre-on-event this e) #t]
904       [just-pre? block-all-mouse-events?]
905       [else (when enabled? (on-event e)) #t]))
906
907    (define/public (call-pre-on-event w e)
908      (or (send parent call-pre-on-event w e)
909          (pre-on-event w e)))
910    (define/public (call-pre-on-char w e)
911      (or (send parent call-pre-on-char w e)
912          (pre-on-char w e)))
913    (define/public (pre-on-event w e) #f)
914    (define/public (pre-on-char w e) #f)
915
916    (define/public (key-event-as-string s timestamp)
917      (dispatch-on-char (new key-event%
918                             [key-code (string-ref s 0)]
919                             [shift-down #f]
920                             [control-down #f]
921                             [meta-down #f]
922                             [alt-down #f]
923                             [x 0]
924                             [y 0]
925                             [time-stamp (->long (* timestamp 1000.0))]
926                             [caps-down #f])
927                        #f))
928
929    (define/public (post-mouse-down) (void))
930
931    (define/public (on-char s) (void))
932    (define/public (on-event m) (void))
933    (define/public (queue-on-size) (void))
934
935    (define last-l? #f)
936    (define last-m? #f)
937    (define last-r? #f)
938    (define/public (set-last-buttons l? m? r?)
939      (set! last-l? l?)
940      (set! last-m? m?)
941      (set! last-r? r?))
942    (define/public (get-last-left-button) last-l?)
943    (define/public (get-last-middle-button) last-m?)
944    (define/public (get-last-right-button) last-r?)
945
946    (define wheel-steps-mode 'one)
947    (define leftover-wheel-x 0.0)
948    (define leftover-wheel-y 0.0)
949    (define/public (get-wheel-state)
950      (values leftover-wheel-y leftover-wheel-x wheel-steps-mode))
951    (define/public (set-wheel-state y x)
952      (set! leftover-wheel-y y)
953      (set! leftover-wheel-x x))
954    (define/public (get-wheel-steps-mode) wheel-steps-mode)
955    (define/public (set-wheel-steps-mode mode) (set! wheel-steps-mode mode))
956
957    (define/public (set-sticky-cursor)
958      (set! sticky-cursor? #t))
959
960    (define/public (start-no-cursor-rects)
961      (send (get-parent) start-no-cursor-rects))
962    (define/public (end-no-cursor-rects)
963      (set! sticky-cursor? #f)
964      (send (get-parent) end-no-cursor-rects))
965
966    (define/public (get-handle) (get-cocoa))
967    (define/public (get-client-handle) (get-cocoa-content))
968
969    (define/public (popup-menu m x y)
970      (send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y)
971            (lambda (thunk)
972              (queue-window-event this thunk))))
973
974    (define/public (center a b) (void))
975    (define/public (refresh) (refresh-all-children))
976
977    (define/public (refresh-all-children) (void))
978
979    (define/public (screen-to-client xb yb)
980      (internal-screen-to-client xb yb))
981    (define/public (internal-screen-to-client xb yb)
982      (let ([p (tell #:type _NSPoint (get-cocoa-content)
983                     convertPoint: #:type _NSPoint
984                     (tell #:type _NSPoint (get-cocoa-window)
985                           convertScreenToBase:
986                           #:type _NSPoint (make-NSPoint (unbox xb)
987                                                         (send (get-wx-window) flip-screen (unbox yb))))
988                     fromView: #f)])
989        (set-box! xb (inexact->exact (floor (NSPoint-x p))))
990        (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p)))))))
991
992    (define/public (client-to-screen xb yb [flip-y? #t])
993      (internal-client-to-screen xb yb flip-y?))
994    (define/public (internal-client-to-screen xb yb [flip-y? #t])
995      (let* ([p (tell #:type _NSPoint (get-cocoa-window)
996                      convertBaseToScreen:
997                      #:type _NSPoint
998                      (tell #:type _NSPoint (get-cocoa-content)
999                            convertPoint: #:type _NSPoint
1000                            (make-NSPoint (unbox xb) (flip-client (unbox yb)))
1001                            toView: #f))])
1002        (let ([new-y (if flip-y?
1003                         (send (get-wx-window) flip-screen (NSPoint-y p))
1004                         (NSPoint-y p))])
1005          (set-box! xb (inexact->exact (floor (NSPoint-x p))))
1006          (set-box! yb (inexact->exact (floor new-y))))))
1007
1008    (define cursor-handle #f)
1009    (define sticky-cursor? #f)
1010    (define/public (set-cursor c)
1011      (let ([h (if c
1012                   (send (send c get-driver) get-handle)
1013                   #f)])
1014        (unless (eq? h cursor-handle)
1015          (atomically
1016           (set! cursor-handle h)
1017           (when sticky-cursor? (tellv h set))
1018           (tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content))))))
1019    (define/public (reset-cursor-rects)
1020      ;; called in event-pump thread
1021      (when cursor-handle
1022        (let ([content (get-cocoa-cursor-content)])
1023          (let* ([r (tell #:type _NSRect content frame)]
1024                 [r (make-NSRect (make-NSPoint 0 0)
1025                                 (make-NSSize
1026                                  (- (NSSize-width (NSRect-size r))
1027                                     (get-cursor-width-delta))
1028                                  (NSSize-height (NSRect-size r))))])
1029            (tellv content addCursorRect: #:type _NSRect r cursor: cursor-handle)))))
1030    (define/public (get-cursor-width-delta) 0)
1031
1032    (define/public (can-accept-focus?) #f)
1033    (define/public (gets-focus?) (can-accept-focus?))
1034    (define/public (can-be-responder?) (is-enabled-to-root?))
1035
1036    (define/public (on-color-change)
1037      (send parent on-color-change))
1038
1039    ;; For multi-key character composition:
1040    (define saved-marked #f)
1041    (define saved-sel #f)
1042    (define/public (set-saved-marked v sel)
1043      (set! saved-marked v)
1044      (set! saved-sel sel)
1045      (if (and v
1046               (not (string=? v ""))
1047               ;; Don't show the window for an empty string or certain
1048               ;; simple combinations (probably a better way than this);
1049               (not (member v '("¨" "ˆ" "´" "`" "˜"))))
1050          (create-compose-window)
1051          (when compose-cocoa
1052            (tellv compose-cocoa orderOut: #f))))
1053    (define/public (get-saved-marked) saved-marked)
1054    (define/public (get-saved-selected) saved-sel)
1055
1056    (define/public (warp-pointer x y)
1057      (define xb (box x))
1058      (define yb (box y))
1059      (client-to-screen xb yb)
1060      (void (CGWarpMouseCursorPosition (make-NSPoint (unbox xb) (unbox yb))))
1061      (void (CGAssociateMouseAndMouseCursorPosition #t)))
1062
1063    (define/private (create-compose-window)
1064      (unless compose-cocoa
1065        (set! compose-cocoa (tell (tell InputMethodPanel alloc)
1066                                  initWithContentRect: #:type _NSRect (make-NSRect
1067                                                                       (make-NSPoint 0 20)
1068                                                                       (make-NSSize 300 20))
1069                                  styleMask: #:type _int (bitwise-ior NSUtilityWindowMask
1070                                                                      NSResizableWindowMask
1071                                                                      NSClosableWindowMask)
1072                                  backing: #:type _int NSBackingStoreBuffered
1073                                  defer: #:type _BOOL NO))
1074        (set! compose-text (tell (tell NSTextView alloc)
1075                                 initWithFrame: #:type _NSRect (make-NSRect
1076                                                                (make-NSPoint 0 0)
1077                                                                (make-NSSize 10 10))))
1078        (tellv compose-cocoa setFloatingPanel: #:type _BOOL #t)
1079        (tellv (tell compose-cocoa contentView) addSubview: compose-text)
1080        (tellv compose-text sizeToFit)
1081        (tellv compose-cocoa setContentBorderThickness: #:type _CGFloat 5.0 forEdge: #:type _int 1)
1082        (let ([h (+ (NSSize-height
1083                     (NSRect-size
1084                      (tell #:type _NSRect
1085                            compose-cocoa frameRectForContentRect:
1086                            #:type _NSRect (make-NSRect (make-NSPoint 0 0)
1087                                                        (make-NSSize 0 0)))))
1088                    (NSSize-height (NSRect-size (tell #:type _NSRect compose-text frame))))])
1089          (tellv compose-cocoa setMinSize: #:type _NSSize (make-NSSize 1 h))
1090          (tellv compose-cocoa setMaxSize: #:type _NSSize (make-NSSize 32000 h))
1091          (tellv compose-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 20)
1092                                                                     (make-NSSize 300 h))
1093                 display: #:type _BOOL #t))
1094        (reset-input-method-window-size)
1095        (tellv compose-cocoa setDelegate: compose-cocoa))
1096      (tellv compose-text
1097             setMarkedText: #:type _NSString saved-marked
1098             selectedRange: #:type _NSRange (make-NSRange (car saved-sel) (cdr saved-sel)))
1099      (tellv compose-cocoa orderFront: #f))))
1100
1101(define (reset-input-method-window-size)
1102  (when compose-text
1103    (tell compose-text setFrame: #:type _NSRect
1104          (tell #:type _NSRect (tell compose-cocoa contentView) frame))))
1105
1106(define compose-cocoa #f)
1107(define compose-text #f)
1108
1109;; ----------------------------------------
1110
1111(define (queue-window-event wx thunk)
1112  (queue-event (send wx get-eventspace) thunk))
1113
1114(define (queue-window-refresh-event wx thunk)
1115  (queue-refresh-event (send wx get-eventspace) thunk))
1116
1117(define (queue-window*-event wxb proc)
1118  (let ([wx (->wx wxb)])
1119    (when wx
1120      (queue-event (send wx get-eventspace) (lambda () (proc wx))))))
1121
1122(define (request-flush-delay wx-win)
1123  (do-request-flush-delay
1124   wx-win
1125   (lambda (wx-win)
1126     (and (tell #:type _BOOL (send wx-win get-cocoa-window) isVisible)
1127          (send wx-win disable-flush-window)
1128          #t))
1129   (lambda (wx-win)
1130     (send wx-win enable-flush-window))))
1131
1132(define (cancel-flush-delay req)
1133  (do-cancel-flush-delay
1134   req
1135   (lambda (wx-win)
1136     (send wx-win enable-flush-window))))
1137
1138(define (make-init-point x y)
1139  (make-NSPoint (if (not x)
1140                    0
1141                    x)
1142                (if (not y)
1143                    0
1144                    y)))
1145
1146(define (flush-display)
1147  (try-to-sync-refresh)
1148  (for ([win (in-list (get-top-level-windows))])
1149    (send win flush)))
1150