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

another refinement to cocoa key handling

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-04 07:38:14 -06:00
parent 15a7a2a006
commit cc737fc571
1 changed files with 80 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -53,6 +53,8 @@
(import-class NSArray) (import-class NSArray)
(import-protocol NSTextInput) (import-protocol NSTextInput)
(define current-insert-text (make-parameter #f))
(define-objc-mixin (KeyMouseResponder Superclass) (define-objc-mixin (KeyMouseResponder Superclass)
[wxb] [wxb]
[-a _void (mouseDown: [_id event]) [-a _void (mouseDown: [_id event])
@ -106,19 +108,34 @@
(super-tell #:type _void otherMouseDragged: event))] (super-tell #:type _void otherMouseDragged: event))]
[-a _void (keyDown: [_id event]) [-a _void (keyDown: [_id event])
(unless (do-key-event wxb event) (unless (do-key-event wxb event self)
(super-tell #:type _void keyDown: event))] (super-tell #:type _void keyDown: event))]
[-a _void (insertText: [_NSString str]) [-a _void (insertText: [_NSString str])
(let ([wx (->wx wxb)]) (let ([cit (current-insert-text)])
(post-dummy-event) ;; to wake up in case of character palette insert (if cit
(when wx (set-box! cit str)
(queue-window-event wx (lambda () (let ([wx (->wx wxb)])
(send wx key-event-as-string str)))))] (post-dummy-event) ;; to wake up in case of character palette insert
(when wx
(queue-window-event wx (lambda ()
(send wx key-event-as-string str)))))))]
;; for NSTextInput, to enable character palette insert: ;; for NSTextInput:
[-a _BOOL (hasMarkedText) #f] [-a _BOOL (hasMarkedText) #f]
[-a _id (validAttributesForMarkedText) [-a _id (validAttributesForMarkedText)
(tell NSArray array)]) (tell NSArray array)]
[-a _void (unmarkText) (void)]
[-a _NSRange (markedRange) (make-NSRange 0 0)]
[-a _NSRange (selectedRange) (make-NSRange 0 0)]
[-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange])
(void)]
[-a _id (validAttributesForMarkedText) #f]
[-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f]
[-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0]
[-a _NSInteger (conversationIdentifier) 0]
[-a _void (doCommandBySelector: [_SEL aSelector]) (void)]
[-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0)
(make-NSSize 0 0))])
(define-objc-mixin (KeyMouseTextResponder Superclass) (define-objc-mixin (KeyMouseTextResponder Superclass)
#:mixins (KeyMouseResponder) #:mixins (KeyMouseResponder)
@ -132,51 +149,64 @@
(when wx (when wx
(send wx reset-cursor-rects)))]) (send wx reset-cursor-rects)))])
(define (do-key-event wxb event) (define (do-key-event wxb event self)
(let ([wx (->wx wxb)]) (let ([wx (->wx wxb)])
(and (and
wx wx
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] (let ([inserted-text (box #f)])
[bit? (lambda (m b) (positive? (bitwise-and m b)))] ;; Calling `interpretKeyEvents:' allows key combinations to be
[pos (tell #:type _NSPoint event locationInWindow)] ;; handled, such as option-e followed by e to produce é. The
[str (tell #:type _NSString event characters)] ;; call to `interpretKeyEvents:' typically calls `insertText:',
[control? (bit? modifiers NSControlKeyMask)]) ;; so we set `current-insert-text' to tell `insertText:' to just
(let-values ([(x y) (send wx window-point-to-view pos)]) ;; give us back the text in the parameter. For now, we ignore the
(let ([k (new key-event% ;; text and handle the event as usual, though probably we should
[key-code (or ;; be doing something with it.
(map-key-code (tell #:type _ushort event keyCode)) (parameterize ([current-insert-text inserted-text])
(if (string=? "" str) (tellv self interpretKeyEvents: (tell (tell NSArray alloc)
#\nul initWithObjects: #:type (_ptr i _id) event
(let ([c (string-ref str 0)]) count: #:type _NSUInteger 1)))
(or (and control?
(char<=? #\u00 c #\u1a) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) [bit? (lambda (m b) (positive? (bitwise-and m b)))]
(and (string? alt-str) [pos (tell #:type _NSPoint event locationInWindow)]
(= 1 (string-length alt-str)) [str (tell #:type _NSString event characters)]
(string-ref alt-str 0)))) [control? (bit? modifiers NSControlKeyMask)])
c))))] (let-values ([(x y) (send wx window-point-to-view pos)])
[shift-down (bit? modifiers NSShiftKeyMask)] (let ([k (new key-event%
[control-down control?] [key-code (or
[meta-down (bit? modifiers NSCommandKeyMask)] (map-key-code (tell #:type _ushort event keyCode))
[alt-down (bit? modifiers NSAlternateKeyMask)] (if (string=? "" str)
[x (->long x)] #\nul
[y (->long y)] (let ([c (string-ref str 0)])
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] (or (and control?
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) (char<=? #\u00 c #\u1a)
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
(when (and (string? alt-str) (and (string? alt-str)
(= 1 (string-length alt-str))) (= 1 (string-length alt-str))
(let ([alt-code (string-ref alt-str 0)]) (string-ref alt-str 0))))
(unless (equal? alt-code (send k get-key-code)) c))))]
(send k set-other-altgr-key-code alt-code))))) [shift-down (bit? modifiers NSShiftKeyMask)]
(if (send wx definitely-wants-event? k) [control-down control?]
(begin [meta-down (bit? modifiers NSCommandKeyMask)]
(queue-window-event wx (lambda () [alt-down (bit? modifiers NSAlternateKeyMask)]
(send wx dispatch-on-char k #f))) [x (->long x)]
#t) [y (->long y)]
(constrained-reply (send wx get-eventspace) [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
(lambda () (send wx dispatch-on-char k #t)) [caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
#t)))))))) (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
(when (and (string? alt-str)
(= 1 (string-length alt-str)))
(let ([alt-code (string-ref alt-str 0)])
(unless (equal? alt-code (send k get-key-code))
(send k set-other-altgr-key-code alt-code)))))
(if (send wx definitely-wants-event? k)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-char k #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t))
#t)))))))))
(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind]) (define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind])
(let ([wx (->wx wxb)]) (let ([wx (->wx wxb)])