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

gtk: fix button enable when mouse is over button

Browse Source 
original commit: 49903be78fb4b0d9ad297b2b792775bf1d9762d9
This commit is contained in:
Matthew Flatt 2011-04-15 16:54:22 -06:00
parent 2d275e014c
commit 2273e70c10
1 changed files with 76 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
collects/mred/private/wx/gtk/window.rkt
View File

@ -300,72 +300,82 @@
(if crossing? (if crossing?
(GdkEventCrossing-type event) (GdkEventCrossing-type event)
(GdkEventButton-type event)))]) (GdkEventButton-type event)))])
(unless (or (= type GDK_2BUTTON_PRESS) (let ([wx (gtk->wx gtk)])
(= type GDK_3BUTTON_PRESS)) (and
(let ([wx (gtk->wx gtk)]) wx
(and (if (or (= type GDK_2BUTTON_PRESS)
wx (= type GDK_3BUTTON_PRESS))
(let* ([modifiers (if motion? #t
(GdkEventMotion-state event) (let* ([modifiers (if motion?
(if crossing? (GdkEventMotion-state event)
(GdkEventCrossing-state event) (if crossing?
(GdkEventButton-state event)))] (GdkEventCrossing-state event)
[bit? (lambda (m v) (positive? (bitwise-and m v)))] (GdkEventButton-state event)))]
[type (cond [bit? (lambda (m v) (positive? (bitwise-and m v)))]
[(= type GDK_MOTION_NOTIFY) [type (cond
'motion] [(= type GDK_MOTION_NOTIFY)
[(= type GDK_ENTER_NOTIFY) 'motion]
'enter] [(= type GDK_ENTER_NOTIFY)
[(= type GDK_LEAVE_NOTIFY) 'enter]
'leave] [(= type GDK_LEAVE_NOTIFY)
[(= type GDK_BUTTON_PRESS) 'leave]
(case (GdkEventButton-button event) [(= type GDK_BUTTON_PRESS)
[(1) 'left-down] (case (GdkEventButton-button event)
[(3) 'right-down] [(1) 'left-down]
[else 'middle-down])] [(3) 'right-down]
[else [else 'middle-down])]
(case (GdkEventButton-button event) [else
[(1) 'left-up] (case (GdkEventButton-button event)
[(3) 'right-up] [(1) 'left-up]
[else 'middle-up])])] [(3) 'right-up]
[m (new mouse-event% [else 'middle-up])])]
[event-type type] [m (new mouse-event%
[left-down (case type [event-type type]
[(left-down) #t] [left-down (case type
[(left-up) #f] [(left-down) #t]
[else (bit? modifiers GDK_BUTTON1_MASK)])] [(left-up) #f]
[middle-down (case type [else (bit? modifiers GDK_BUTTON1_MASK)])]
[(middle-down) #t] [middle-down (case type
[(middle-up) #f] [(middle-down) #t]
[else (bit? modifiers GDK_BUTTON2_MASK)])] [(middle-up) #f]
[right-down (case type [else (bit? modifiers GDK_BUTTON2_MASK)])]
[(right-down) #t] [right-down (case type
[(right-up) #f] [(right-down) #t]
[else (bit? modifiers GDK_BUTTON3_MASK)])] [(right-up) #f]
[x (->long ((if motion? [else (bit? modifiers GDK_BUTTON3_MASK)])]
GdkEventMotion-x [x (->long ((if motion?
(if crossing? GdkEventCrossing-x GdkEventButton-x)) GdkEventMotion-x
event))] (if crossing? GdkEventCrossing-x GdkEventButton-x))
[y (->long ((if motion? GdkEventMotion-y event))]
(if crossing? GdkEventCrossing-y GdkEventButton-y)) [y (->long ((if motion? GdkEventMotion-y
event))] (if crossing? GdkEventCrossing-y GdkEventButton-y))
[shift-down (bit? modifiers GDK_SHIFT_MASK)] event))]
[control-down (bit? modifiers GDK_CONTROL_MASK)] [shift-down (bit? modifiers GDK_SHIFT_MASK)]
[meta-down (bit? modifiers GDK_META_MASK)] [control-down (bit? modifiers GDK_CONTROL_MASK)]
[alt-down (bit? modifiers GDK_MOD1_MASK)] [meta-down (bit? modifiers GDK_META_MASK)]
[time-stamp ((if motion? GdkEventMotion-time [alt-down (bit? modifiers GDK_MOD1_MASK)]
(if crossing? GdkEventCrossing-time GdkEventButton-time)) [time-stamp ((if motion? GdkEventMotion-time
event)] (if crossing? GdkEventCrossing-time GdkEventButton-time))
[caps-down (bit? modifiers GDK_LOCK_MASK)])]) event)]
(if (send wx handles-events? gtk) [caps-down (bit? modifiers GDK_LOCK_MASK)])])
(begin (if (send wx handles-events? gtk)
(queue-window-event wx (lambda () (begin
(send wx dispatch-on-event m #f))) (queue-window-event wx (lambda ()
#t) (send wx dispatch-on-event m #f)))
(constrained-reply (send wx get-eventspace) #t)
(lambda () (or (send wx dispatch-on-event m #t) (constrained-reply (send wx get-eventspace)
(send wx internal-pre-on-event gtk m))) (lambda () (or (send wx dispatch-on-event m #t)
#t)))))))) (send wx internal-pre-on-event gtk m)))
#t
#:fail-result
;; an enter event is synthesized when a button is
;; enabled and the mouse is over the button, and the
;; event is not dispatched via the eventspace; leave
;; events are perhaps similarly synthesized, so allow
;; them, too
(if (or (eq? type 'enter) (eq? type 'leave))
#f
#t)))))))))
;; ---------------------------------------- ;; ----------------------------------------