From ba7d6d7cc13da6a5d2683e4a6bd74eb13f910f2f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Sep 2010 15:15:42 -0600 Subject: [PATCH] cocoa mouse event and cursor fixes original commit: c3fa1f01e8babe7355ba3a5a063f96091fcb7c74 --- collects/mred/private/wx/cocoa/frame.rkt | 7 ++ collects/mred/private/wx/cocoa/window.rkt | 96 +++++++++++++++++------ collects/tests/gracket/showkey.rkt | 53 ++++++------- 3 files changed, 105 insertions(+), 51 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index c6f01ec3..3dbec1b2 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -345,6 +345,13 @@ (install-wait-cursor) (uninstall-wait-cursor)))) + (define/override (start-no-cursor-rects) + (tell cocoa disableCursorRects)) + + (define/override (end-no-cursor-rects) + (unless (positive? (eventspace-wait-cursor-count (get-eventspace))) + (tell cocoa enableCursorRects))) + (define/public (flip-screen y) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (- (NSSize-height (NSRect-size f)) y))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index e2a3a0a3..dab0c839 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -99,12 +99,19 @@ (loop (tell hit superview))))))] [-a _BOOL (doMouseMoved: [_id event]) ;; called by mouseMoved: - (do-mouse-event wxb event 'motion #f #f #f)] + (and + ;; Make sure we're in the right eventspace: + (let ([wx (->wx wxb)]) + (and wx + (eq? (current-eventspace) + (send wx get-eventspace)))) + ;; Right event space, so handle the event: + (do-mouse-event wxb event 'motion #f #f #f))] [-a _void (mouseEntered: [_id event]) - (unless (do-mouse-event wxb event 'enter #f #f #f) + (unless (do-mouse-event wxb event 'enter 'check 'check 'check) (super-tell #:type _void mouseEntered: event))] [-a _void (mouseExited: [_id event]) - (unless (do-mouse-event wxb event 'leave #f #f #f) + (unless (do-mouse-event wxb event 'leave 'check 'check 'check) (super-tell #:type _void mouseExited: event))] [-a _void (rightMouseDown: [_id event]) (unless (do-mouse-event wxb event 'right-down #f #f #t) @@ -249,27 +256,46 @@ [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)]) (let-values ([(x y) (send wx window-point-to-view pos)] - [(control-down) (bit? modifiers NSControlKeyMask)]) - (let ([m (new mouse-event% - [event-type (if control-down ctl-kind kind)] - [left-down (and l? (not control-down))] - [middle-down m?] - [right-down (or r? (and l? control-down))] - [x (->long x)] - [y (->long y)] - [shift-down (bit? modifiers NSShiftKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx definitely-wants-event? m) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event/sync m))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-event m #t)) - #t)))))))) + [(control-down) (bit? modifiers NSControlKeyMask)] + [(l?) (if (eq? l? 'check) + (send wx get-last-left-button) + l?)] + [(m?) (if (eq? m? 'check) + (send wx get-last-middle-button) + m?)] + [(r?) (if (eq? r? 'check) + (send wx get-last-right-button) + r?)]) + (let ([l? (and l? (not control-down))] + [r? (or r? (and l? control-down))]) + (send wx set-last-buttons l? m? r?) + (let ([m (new mouse-event% + [event-type (if control-down ctl-kind kind)] + [left-down l?] + [middle-down m?] + [right-down r?] + [x (->long x)] + [y (->long y)] + [shift-down (bit? modifiers NSShiftKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (cond + [(send m dragging?) (void)] + [(send m button-down?) + (send wx set-sticky-cursor) + (send wx start-no-cursor-rects)] + [(or l? m? r?) (void)] + [else (send wx end-no-cursor-rects)]) + (if (send wx definitely-wants-event? m) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event/sync m))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t))))))))) (define window% (class object% @@ -507,6 +533,26 @@ (define/public (on-event m) (void)) (define/public (on-size x y) (void)) + (define last-l? #f) + (define last-m? #f) + (define last-r? #f) + (define/public (set-last-buttons l? m? r?) + (set! last-l? l?) + (set! last-m? m?) + (set! last-r? r?)) + (define/public (get-last-left-button) last-l?) + (define/public (get-last-middle-button) last-m?) + (define/public (get-last-right-button) last-r?) + + (define/public (set-sticky-cursor) + (set! sticky-cursor? #t)) + + (define/public (start-no-cursor-rects) + (send (get-parent) start-no-cursor-rects)) + (define/public (end-no-cursor-rects) + (set! sticky-cursor? #f) + (send (get-parent) end-no-cursor-rects)) + (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) @@ -543,6 +589,7 @@ (def/public-unimplemented fit) (define cursor-handle #f) + (define sticky-cursor? #f) (define/public (set-cursor c) (let ([h (if c (send (send c get-driver) get-handle) @@ -550,6 +597,7 @@ (unless (eq? h cursor-handle) (atomically (set! cursor-handle h) + (when sticky-cursor? (tellv h set)) (tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content)))))) (define/public (reset-cursor-rects) ;; called in event-pump thread diff --git a/collects/tests/gracket/showkey.rkt b/collects/tests/gracket/showkey.rkt index 124c4323..9f7705ec 100644 --- a/collects/tests/gracket/showkey.rkt +++ b/collects/tests/gracket/showkey.rkt @@ -16,33 +16,32 @@ (class canvas% (super-new) (define/override (on-event ev) - (lambda (ev) - (printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" - (es-check) - iter - (send ev get-event-type) - (send ev get-x) - (send ev get-y) - (if (send ev get-meta-down) " META" "") - (if (send ev get-control-down) " CTL" "") - (if (send ev get-alt-down) " ALT" "") - (if (send ev get-shift-down) " SHIFT" "") - (if (send ev get-caps-down) " CAPS" "") - (if (send ev get-left-down) " LEFT" "") - (if (send ev get-middle-down) " MIDDLE" "") - (if (send ev get-right-down) " RIGHT" "") - (if (send ev dragging?) - " dragging" - "") - (if (send ev moving?) - " moving" - "") - (if (send ev entering?) - " entering" - "") - (if (send ev leaving?) - " leaving" - "")))) + (printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" + (es-check) + iter + (send ev get-event-type) + (send ev get-x) + (send ev get-y) + (if (send ev get-meta-down) " META" "") + (if (send ev get-control-down) " CTL" "") + (if (send ev get-alt-down) " ALT" "") + (if (send ev get-shift-down) " SHIFT" "") + (if (send ev get-caps-down) " CAPS" "") + (if (send ev get-left-down) " LEFT" "") + (if (send ev get-middle-down) " MIDDLE" "") + (if (send ev get-right-down) " RIGHT" "") + (if (send ev dragging?) + " dragging" + "") + (if (send ev moving?) + " moving" + "") + (if (send ev entering?) + " entering" + "") + (if (send ev leaving?) + " leaving" + ""))) (define/override (on-char ev) (set! iter (add1 iter)) (printf "~a~a KEY: ~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a\n"