cocoa: handle multi-key character input
This commit is contained in:
Matthew Flatt
parent
0540359965
commit
e0bcec0825
|
|
@ -82,6 +82,16 @@
|
|||
|
||||
(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)
|
||||
[wxb]
|
||||
[-a _void (mouseDown: [_id event])
|
||||
|
|
@ -152,7 +162,7 @@
|
|||
[-a _void (keyUp: [_id event])
|
||||
(unless (do-key-event wxb event self #f #f)
|
||||
(super-tell #:type _void keyUp: event))]
|
||||
[-a _void (insertText: [_NSString str])
|
||||
[-a _void (insertText: [_NSStringOrAttributed str])
|
||||
(let ([cit (current-insert-text)])
|
||||
(if cit
|
||||
(set-box! cit str)
|
||||
|
|
@ -163,24 +173,47 @@
|
|||
(send wx key-event-as-string str)))))))]
|
||||
|
||||
;; for NSTextInput:
|
||||
[-a _BOOL (hasMarkedText) #f]
|
||||
[-a _BOOL (hasMarkedText) (get-saved-marked wxb)]
|
||||
[-a _id (validAttributesForMarkedText)
|
||||
(tell NSArray array)]
|
||||
[-a _void (unmarkText) (void)]
|
||||
[-a _NSRange (markedRange) (make-NSRange 0 0)]
|
||||
[-a _void (unmarkText)
|
||||
(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 _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
|
||||
;; key is a dead key for composing some other character.
|
||||
(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)]
|
||||
[-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 _NSInteger (conversationIdentifier) 0]
|
||||
[-a _void (doCommandBySelector: [_SEL aSelector]) (void)]
|
||||
[-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0)
|
||||
(make-NSSize 0 0))]
|
||||
[-a _NSRect (firstRectForCharacterRange: [_NSRange r])
|
||||
;; 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:
|
||||
[-a _int (draggingEntered: [_id info])
|
||||
|
|
@ -200,6 +233,18 @@
|
|||
(lambda ()
|
||||
(send wx do-on-drop-file s)))))))))))
|
||||
#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)
|
||||
#:mixins (KeyMouseResponder)
|
||||
|
|
@ -246,25 +291,30 @@
|
|||
[control? (bit? modifiers NSControlKeyMask)]
|
||||
[option? (bit? modifiers NSAlternateKeyMask)]
|
||||
[delta-y (and wheel?
|
||||
(tell #:type _CGFloat event deltaY))])
|
||||
(let-values ([(x y) (send wx window-point-to-view pos)])
|
||||
(let ([k (new key-event%
|
||||
[key-code (if wheel?
|
||||
(if (positive? delta-y)
|
||||
'wheel-up
|
||||
'wheel-down)
|
||||
(or
|
||||
(map-key-code (tell #:type _ushort event keyCode))
|
||||
(if (string=? "" str)
|
||||
#\nul
|
||||
(tell #:type _CGFloat event deltaY))]
|
||||
[codes (cond
|
||||
[wheel? (if (positive? delta-y)
|
||||
'(wheel-up)
|
||||
'(wheel-down))]
|
||||
[(map-key-code (tell #:type _ushort event keyCode))
|
||||
=> list]
|
||||
[(string=? "" str) '(#\nul)]
|
||||
[(and (= 1 (string-length str))
|
||||
(let ([c (string-ref str 0)])
|
||||
(or (and control?
|
||||
(char<=? #\u00 c #\u1F)
|
||||
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
|
||||
(and (string? alt-str)
|
||||
(= 1 (string-length alt-str))
|
||||
(string-ref alt-str 0))))
|
||||
c)))))]
|
||||
(string-ref alt-str 0)))))))
|
||||
=> list]
|
||||
[else str])])
|
||||
(for/fold ([result #f]) ([one-code codes])
|
||||
(or
|
||||
;; Handle one key event
|
||||
(let-values ([(x y) (send wx window-point-to-view pos)])
|
||||
(let ([k (new key-event%
|
||||
[key-code one-code]
|
||||
[shift-down (bit? modifiers NSShiftKeyMask)]
|
||||
[control-down control?]
|
||||
[meta-down (bit? modifiers NSCommandKeyMask)]
|
||||
|
|
@ -300,7 +350,8 @@
|
|||
#t)
|
||||
(constrained-reply (send wx get-eventspace)
|
||||
(lambda () (send wx dispatch-on-char k #t))
|
||||
#t)))))))))
|
||||
#t))))
|
||||
result)))))))
|
||||
|
||||
(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind])
|
||||
(let ([wx (->wx wxb)])
|
||||
|
|
@ -725,8 +776,12 @@
|
|||
(define/public (can-be-responder?) #t)
|
||||
|
||||
(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)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user