diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 5a470bf682..06a6491f8e 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -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]) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index d5dc26d02d..11a8278d1e 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -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))))