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