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

cocoa: handle multi-key character input

Browse Source
This commit is contained in:
Matthew Flatt 2010-11-25 10:38:28 -07:00
parent 0540359965
commit e0bcec0825
1 changed files with 119 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -82,6 +82,16 @@
(define NSDragOperationCopy 1) (define NSDragOperationCopy 1)
(import-class NSAttributedString)
(define _NSStringOrAttributed
(make-ctype _id
(lambda (v)
(cast v _NSString _id))
(lambda (v)
(if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class))
(tell #:type _NSString v string)
(cast v _id _NSString)))))
(define-objc-mixin (KeyMouseResponder Superclass) (define-objc-mixin (KeyMouseResponder Superclass)
[wxb] [wxb]
[-a _void (mouseDown: [_id event]) [-a _void (mouseDown: [_id event])
@ -152,7 +162,7 @@
[-a _void (keyUp: [_id event]) [-a _void (keyUp: [_id event])
(unless (do-key-event wxb event self #f #f) (unless (do-key-event wxb event self #f #f)
(super-tell #:type _void keyUp: event))] (super-tell #:type _void keyUp: event))]
[-a _void (insertText: [_NSString str]) [-a _void (insertText: [_NSStringOrAttributed str])
(let ([cit (current-insert-text)]) (let ([cit (current-insert-text)])
(if cit (if cit
(set-box! cit str) (set-box! cit str)
@ -163,24 +173,47 @@
(send wx key-event-as-string str)))))))] (send wx key-event-as-string str)))))))]
;; for NSTextInput: ;; for NSTextInput:
[-a _BOOL (hasMarkedText) #f] [-a _BOOL (hasMarkedText) (get-saved-marked wxb)]
[-a _id (validAttributesForMarkedText) [-a _id (validAttributesForMarkedText)
(tell NSArray array)] (tell NSArray array)]
[-a _void (unmarkText) (void)] [-a _void (unmarkText)
[-a _NSRange (markedRange) (make-NSRange 0 0)] (set-saved-marked! wxb #f)]
[-a _NSRange (markedRange)
(let ([saved-marked (get-saved-marked wxb)])
(make-NSRange 0 (if saved-marked 0 (length saved-marked))))]
[-a _NSRange (selectedRange) (make-NSRange 0 0)] [-a _NSRange (selectedRange) (make-NSRange 0 0)]
[-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange]) [-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange])
;; We interpreter a call to `setMarkedText:' as meaning that the ;; We interpreter a call to `setMarkedText:' as meaning that the
;; key is a dead key for composing some other character. ;; key is a dead key for composing some other character.
(let ([m (current-set-mark)]) (when m (set-box! m #t))) (let ([m (current-set-mark)]) (when m (set-box! m #t)))
;; At the same time, we need to remember the text:
(set-saved-marked! wxb (range-substring aString selRange))
(void)] (void)]
[-a _id (validAttributesForMarkedText) #f] [-a _id (validAttributesForMarkedText) #f]
[-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f] [-a _id (attributedSubstringFromRange: [_NSRange theRange])
(let ([saved-marked (get-saved-marked wxb)])
(and saved-marked
(let ([s (tell (tell NSAttributedString alloc)
initWithString: #:type _NSString
(range-substring saved-marked theRange))])
(tellv s autorelease)
s)))]
[-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0] [-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0]
[-a _NSInteger (conversationIdentifier) 0] [-a _NSInteger (conversationIdentifier) 0]
[-a _void (doCommandBySelector: [_SEL aSelector]) (void)] [-a _void (doCommandBySelector: [_SEL aSelector]) (void)]
[-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0) [-a _NSRect (firstRectForCharacterRange: [_NSRange r])
(make-NSSize 0 0))] ;; This location is used to place a window for multi-character
;; input, such as when typing Chinese with Pinyin
(let ([f (tell #:type _NSRect self frame)]
[pt (tell #:type _NSPoint (tell self window)
convertBaseToScreen:
#:type _NSPoint
(tell #:type _NSPoint self
convertPoint: #:type _NSPoint
(make-NSPoint 0 0)
toView: #f))])
(make-NSRect pt (NSRect-size f)))]
;; Dragging: ;; Dragging:
[-a _int (draggingEntered: [_id info]) [-a _int (draggingEntered: [_id info])
@ -200,6 +233,18 @@
(lambda () (lambda ()
(send wx do-on-drop-file s))))))))))) (send wx do-on-drop-file s)))))))))))
#t]) #t])
(define (set-saved-marked! wxb str)
(let ([wx (->wx wxb)])
(when wx
(send wx set-saved-marked str))))
(define (get-saved-marked wxb)
(let ([wx (->wx wxb)])
(and wx
(send wx get-saved-marked))))
(define (range-substring s range)
(let ([start (min (max 0 (NSRange-location range)) (string-length s))])
(substring s start (max (min start (NSRange-length range)) (string-length s)))))
(define-objc-mixin (KeyMouseTextResponder Superclass) (define-objc-mixin (KeyMouseTextResponder Superclass)
#:mixins (KeyMouseResponder) #:mixins (KeyMouseResponder)
@ -246,61 +291,67 @@
[control? (bit? modifiers NSControlKeyMask)] [control? (bit? modifiers NSControlKeyMask)]
[option? (bit? modifiers NSAlternateKeyMask)] [option? (bit? modifiers NSAlternateKeyMask)]
[delta-y (and wheel? [delta-y (and wheel?
(tell #:type _CGFloat event deltaY))]) (tell #:type _CGFloat event deltaY))]
(let-values ([(x y) (send wx window-point-to-view pos)]) [codes (cond
(let ([k (new key-event% [wheel? (if (positive? delta-y)
[key-code (if wheel? '(wheel-up)
(if (positive? delta-y) '(wheel-down))]
'wheel-up [(map-key-code (tell #:type _ushort event keyCode))
'wheel-down) => list]
(or [(string=? "" str) '(#\nul)]
(map-key-code (tell #:type _ushort event keyCode)) [(and (= 1 (string-length str))
(if (string=? "" str) (let ([c (string-ref str 0)])
#\nul (or (and control?
(let ([c (string-ref str 0)]) (char<=? #\u00 c #\u1F)
(or (and control? (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
(char<=? #\u00 c #\u1F) (and (string? alt-str)
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) (= 1 (string-length alt-str))
(and (string? alt-str) (string-ref alt-str 0)))))))
(= 1 (string-length alt-str)) => list]
(string-ref alt-str 0)))) [else str])])
c)))))] (for/fold ([result #f]) ([one-code codes])
[shift-down (bit? modifiers NSShiftKeyMask)] (or
[control-down control?] ;; Handle one key event
[meta-down (bit? modifiers NSCommandKeyMask)] (let-values ([(x y) (send wx window-point-to-view pos)])
[alt-down option?] (let ([k (new key-event%
[x (->long x)] [key-code one-code]
[y (->long y)] [shift-down (bit? modifiers NSShiftKeyMask)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [control-down control?]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) [meta-down (bit? modifiers NSCommandKeyMask)]
(unless wheel? [alt-down option?]
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) [x (->long x)]
(when (and (string? alt-str) [y (->long y)]
(= 1 (string-length alt-str))) [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
(let ([alt-code (string-ref alt-str 0)]) [caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(unless (equal? alt-code (send k get-key-code)) (unless wheel?
(send k set-other-altgr-key-code alt-code))))) (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
(when (and (or (and option? (when (and (string? alt-str)
special-option-key?) (= 1 (string-length alt-str)))
(and control? (let ([alt-code (string-ref alt-str 0)])
(equal? (send k get-key-code) #\u00))) (unless (equal? alt-code (send k get-key-code))
(send k get-other-altgr-key-code)) (send k set-other-altgr-key-code alt-code)))))
;; swap altenate with main (when (and (or (and option?
(let ([other (send k get-other-altgr-key-code)]) special-option-key?)
(send k set-other-altgr-key-code (send k get-key-code)) (and control?
(send k set-key-code other))) (equal? (send k get-key-code) #\u00)))
(unless down? (send k get-other-altgr-key-code))
;; swap altenate with main ;; swap altenate with main
(send k set-key-release-code (send k get-key-code)) (let ([other (send k get-other-altgr-key-code)])
(send k set-key-code 'release))) (send k set-other-altgr-key-code (send k get-key-code))
(if (send wx definitely-wants-event? k) (send k set-key-code other)))
(begin (unless down?
(queue-window-event wx (lambda () ;; swap altenate with main
(send wx dispatch-on-char/sync k))) (send k set-key-release-code (send k get-key-code))
#t) (send k set-key-code 'release)))
(constrained-reply (send wx get-eventspace) (if (send wx definitely-wants-event? k)
(lambda () (send wx dispatch-on-char k #t)) (begin
#t))))))))) (queue-window-event wx (lambda ()
(send wx dispatch-on-char/sync k)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t))
#t))))
result)))))))
(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)])
@ -725,8 +776,12 @@
(define/public (can-be-responder?) #t) (define/public (can-be-responder?) #t)
(define/public (on-color-change) (define/public (on-color-change)
(send parent on-color-change)))) (send parent on-color-change))
;; For multi-key character composition:
(define saved-marked #f)
(define/public (set-saved-marked v) (set! saved-marked v))
(define/public (get-saved-marked) saved-marked)))
;; ---------------------------------------- ;; ----------------------------------------