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

fix {get,set}-event-type on mouse-event%

Browse Source 
Closes PR 11474
This commit is contained in:
Matthew Flatt 2010-11-30 07:55:41 -07:00
parent 9f9e23f551
commit 8f9a8daa27
2 changed files with 39 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
collects/mred/private/wx/common/event.rkt
View File

@ -14,10 +14,11 @@
(super-new)) (super-new))
(defclass mouse-event% event% (defclass mouse-event% event%
;; FIXME: check event-type (init-properties [[(symbol-in enter leave left-down left-up
(init event-type) middle-down middle-up
(define et event-type) right-down right-up motion)
(init-properties [[bool? left-down] #f] event-type]]
[[bool? left-down] #f]
[[bool? middle-down] #f] [[bool? middle-down] #f]
[[bool? right-down] #f] [[bool? right-down] #f]
[[exact-integer? x] 0] [[exact-integer? x] 0]
@ -30,44 +31,45 @@
(init-properties [[bool? caps-down] #f]) (init-properties [[bool? caps-down] #f])
(super-new [time-stamp time-stamp]) (super-new [time-stamp time-stamp])
(def/public (get-event-type) et)
(def/public (button-changed? [(symbol-in left middle right any) [button 'any]]) (def/public (button-changed? [(symbol-in left middle right any) [button 'any]])
(and (memq et (case button (and (memq event-type
[(any) '(left-down left-up middle-down middle-up right-down right-up)] (case button
[(left) '(left-down left-up)] [(any) '(left-down left-up middle-down middle-up right-down right-up)]
[(middle) '(middle-down middle-up)] [(left) '(left-down left-up)]
[(right) '(right-down right-up)])) [(middle) '(middle-down middle-up)]
[(right) '(right-down right-up)]))
#t)) #t))
(def/public (button-down? [(symbol-in left middle right any) [button 'any]]) (def/public (button-down? [(symbol-in left middle right any) [button 'any]])
(and (memq et (case button (and (memq event-type
[(any) '(left-down middle-down right-down)] (case button
[(left) '(left-down)] [(any) '(left-down middle-down right-down)]
[(middle) '(middle-down)] [(left) '(left-down)]
[(right) '(right-down)])) [(middle) '(middle-down)]
[(right) '(right-down)]))
#t)) #t))
(def/public (button-up? [(symbol-in left middle right any) [button 'any]]) (def/public (button-up? [(symbol-in left middle right any) [button 'any]])
(and (memq et (case button (and (memq event-type
[(any) '(left-up middle-up right-up)] (case button
[(left) '(left-up)] [(any) '(left-up middle-up right-up)]
[(middle) '(middle-up)] [(left) '(left-up)]
[(right) '(right-up)])) [(middle) '(middle-up)]
[(right) '(right-up)]))
#t)) #t))
(def/public (dragging?) (def/public (dragging?)
(and (eq? et 'motion) (and (eq? event-type 'motion)
(or left-down middle-down right-down))) (or left-down middle-down right-down)))
(def/public (entering?) (def/public (entering?)
(eq? et 'enter)) (eq? event-type 'enter))
(def/public (leaving?) (def/public (leaving?)
(eq? et 'leave)) (eq? event-type 'leave))
(def/public (moving?) (def/public (moving?)
(eq? et 'motion))) (eq? event-type 'motion)))
(defclass key-event% event% (defclass key-event% event%
(init-properties [[(make-alts symbol? char?) key-code] #\nul] (init-properties [[(make-alts symbol? char?) key-code] #\nul]
@ -91,9 +93,7 @@
list-box list-box-dclick text-field list-box list-box-dclick text-field
text-field-enter slider radio-box text-field-enter slider radio-box
menu-popdown menu-popdown-none tab-panel) menu-popdown menu-popdown-none tab-panel)
event-type] event-type]])
;; FIXME: should have no default
'button])
(init [time-stamp 0]) (init [time-stamp 0])
(super-new [time-stamp time-stamp])) (super-new [time-stamp time-stamp]))

16
collects/racket/draw/private/syntax.rkt
View File

@ -226,7 +226,7 @@
(define-syntax (do-properties stx) (define-syntax (do-properties stx)
(syntax-case stx () (syntax-case stx ()
[(_ define-base check-immutable [[type id] expr] ...) [(_ define-base check-immutable [[type id] expr ...] ...)
(let ([ids (syntax->list #'(id ...))]) (let ([ids (syntax->list #'(id ...))])
(with-syntax ([(getter ...) (with-syntax ([(getter ...)
(map (lambda (id) (map (lambda (id)
@ -243,7 +243,7 @@
id)) id))
ids)]) ids)])
#'(begin #'(begin
(define-base id expr) ... (define-base id expr ...) ...
(define/public (getter) id) ... (define/public (getter) id) ...
(def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))])) (def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))]))
@ -271,9 +271,15 @@
(do-properties define-init check-immutable . props)] (do-properties define-init check-immutable . props)]
[(_ . props) [(_ . props)
(do-properties define-init void . props)])) (do-properties define-init void . props)]))
(define-syntax-rule (define-init id val) (begin (define-syntax define-init
(init [(internal id) val]) (syntax-rules ()
(define id internal))) [(_ id val) (begin
(init [(internal id) val])
(define id internal))]
[(_ id) (begin
(init [(internal id)])
(define id internal))]))
(define (->long i) (define (->long i)
(cond (cond