suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix mouse-moved events for cocoa

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-29 08:43:38 -06:00
parent 29715fd04b
commit c244a6106a
2 changed files with 39 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/mred/private/wx/cocoa/window.rkt
View File

@ -49,6 +49,19 @@
(unless (do-mouse-event wx event 'motion #t #f #f)
(super-tell #:type _void mouseDragged: event))]
[-a _void (mouseMoved: [_id event])
;; This event is sent to the first responder, instead of the
;; view under the mouse.
(let* ([win (tell event window)]
[view (and win (tell win contentView))]
[hit (and view (tell view hitTest: #:type _NSPoint
(tell #:type _NSPoint event locationInWindow)))])
(let loop ([hit hit])
(when hit
(if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:))
(tell hit doMouseMoved: event)
(loop (tell hit superview))))))]
[-a _void (doMouseMoved: [_id event])
;; called by mouseMoved:
(unless (do-mouse-event wx event 'motion #f #f #f)
(super-tell #:type _void mouseMoved: event))]
[-a _void (mouseEntered: [_id event])

28
collects/mred/private/wx/common/freeze.rkt
View File

@ -36,6 +36,30 @@
freeze-tag)))))
(void))))
(define (internal-error str)
(log-error
(apply string-append
(format "internal error: ~s" str)
(for/list ([c (continuation-mark-set->context (current-continuation-marks))])
(let ([name (car c)]
[loc (cdr c)])
(cond
[loc
(string-append
"\n"
(cond
[(srcloc-line loc)
(format "~a:~a:~a"
(srcloc-source loc)
(srcloc-line loc)
(srcloc-column loc))]
[else
(format "~a::~a"
(srcloc-source loc)
(srcloc-position loc))])
(if name (format " ~a" name) ""))]
[else (format "\n ~a" name)]))))))
;; FIXME: waiting 200msec is not a good enough rule.
(define (constrained-reply es thunk default [should-give-up?
(let ([now (current-inexact-milliseconds)])
@ -43,7 +67,7 @@
((current-inexact-milliseconds) . > . (+ now 200))))])
(let ([b (freezer-box)])
(unless b
(log-error "internal error: constrained-reply not within an unfreeze point"))
(internal-error "constrained-reply not within an unfreeze point"))
(if (eq? (current-thread) (eventspace-handler-thread es))
(if (pair? b)
;; already suspended, so push this work completely:
@ -79,5 +103,5 @@
(scheme_restore_on_atomic_timeout prev))))
freeze-tag))))))
(begin
(log-error "internal error: wrong eventspace for constrained event handling\n")
(internal-error "wrong eventspace for constrained event handling\n")
default))))