cocoa: handle multi-key character input

collects/mred/private/wx/cocoa/window.rkt

@@ -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 _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 _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)
+  [-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:
   [-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))])
+                            (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)
-                                            #\nul
                             (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))))
+                                              (string-ref alt-str 0)))))))
-                                                  c)))))]
+                       => 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)))
 
 ;; ----------------------------------------