gtk: enable input-method (e.g., Chinese) support
original commit: d8e123753c40fadc6d51513cf1fa5e4eca614bc8
This commit is contained in:
Matthew Flatt
parent
d9bea8bf42
commit
d6e4425fbb
|
|
@ -108,6 +108,52 @@
|
|||
(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void))
|
||||
(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void))
|
||||
|
||||
(define _GtkIMContext (_cpointer 'GtkIMContext))
|
||||
(define-gtk gtk_im_multicontext_new (_fun -> _GtkIMContext))
|
||||
(define-gtk gtk_im_context_set_use_preedit (_fun _GtkIMContext _gboolean -> _void))
|
||||
(define-gtk gtk_im_context_focus_in (_fun _GtkIMContext -> _void))
|
||||
(define-gtk gtk_im_context_focus_out (_fun _GtkIMContext -> _void))
|
||||
(define-gtk gtk_im_context_filter_keypress (_fun _GtkIMContext _GdkEventKey-pointer -> _gboolean))
|
||||
(define-gtk gtk_im_context_set_client_window (_fun _GtkIMContext _GdkWindow -> _void))
|
||||
(define-gtk gtk_im_context_set_cursor_location (_fun _GtkIMContext _GdkRectangle-pointer -> _void))
|
||||
|
||||
(define im-string-result #f)
|
||||
(define im-filtering? #f)
|
||||
(define im-canvas #f)
|
||||
|
||||
(define-signal-handler connect-commit "commit"
|
||||
(_fun _GtkIMContext _string -> _void)
|
||||
(lambda (im str)
|
||||
(cond
|
||||
[im-filtering?
|
||||
;; filtering an event => we can handle the string
|
||||
;; result directly
|
||||
(set! im-string-result str)]
|
||||
[(and im-canvas
|
||||
(weak-box-value im-canvas))
|
||||
;; not filtering, but there's a target canvas =>
|
||||
;; queue a made-up key press event for each character
|
||||
;; of the string
|
||||
=> (lambda (wx)
|
||||
(for ([c (in-string str)])
|
||||
(let ([e (new key-event%
|
||||
[key-code c]
|
||||
[shift-down #f]
|
||||
[control-down #f]
|
||||
[meta-down #f]
|
||||
[alt-down #f]
|
||||
[x 0]
|
||||
[y 0]
|
||||
[time-stamp 0]
|
||||
[caps-down #f])])
|
||||
(queue-window-event wx (lambda ()
|
||||
(send wx dispatch-on-char e #f))))))])))
|
||||
|
||||
(define im (gtk_im_multicontext_new))
|
||||
(void (connect-commit (cast im _pointer _GtkWidget)))
|
||||
|
||||
(gtk_im_context_set_use_preedit im #f)
|
||||
|
||||
;; We rely some on the implementation of GtkComboBoxEntry to replace
|
||||
;; the drawing routine.
|
||||
(define-cstruct _GList ([data _pointer]))
|
||||
|
|
@ -595,6 +641,40 @@
|
|||
|
||||
(define/public (set-combo-text t) (void))
|
||||
|
||||
(define/override (focus-change on?)
|
||||
;; input-method management
|
||||
(if on?
|
||||
(begin
|
||||
(set! im-canvas (make-weak-box this))
|
||||
(gtk_im_context_focus_in im)
|
||||
(gtk_im_context_set_client_window im (widget-window client-gtk))
|
||||
(let ([w (box 0)]
|
||||
[h (box 0)])
|
||||
(get-client-size w h)
|
||||
(gtk_im_context_set_cursor_location
|
||||
im
|
||||
(make-GdkRectangle 0 0 (unbox w) (unbox h)))))
|
||||
(when (and im-canvas
|
||||
(eq? this (weak-box-value im-canvas)))
|
||||
(gtk_im_context_focus_out im)
|
||||
(set! im-canvas #f))))
|
||||
|
||||
(define/override (filter-key-event e)
|
||||
;; give the input method a chance to handle the
|
||||
;; key event; see call in "window.rkt" for
|
||||
;; information on the results
|
||||
(if (and im-canvas
|
||||
(eq? this (weak-box-value im-canvas)))
|
||||
(begin
|
||||
(set! im-filtering? #t)
|
||||
(set! im-string-result #f)
|
||||
(if (begin0
|
||||
(gtk_im_context_filter_keypress im e)
|
||||
(set! im-filtering? #f))
|
||||
im-string-result
|
||||
'none))
|
||||
'none))
|
||||
|
||||
(define/public (do-scroll direction)
|
||||
(if (is-auto-scroll?)
|
||||
(refresh-for-autoscroll)
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@
|
|||
(struct-out GdkEventExpose)
|
||||
_GdkEventSelection _GdkEventSelection-pointer
|
||||
(struct-out GdkEventSelection)
|
||||
_GdkRectangle _GdkRectangle-pointer
|
||||
(struct-out GdkRectangle)
|
||||
_GdkColor _GdkColor-pointer
|
||||
(struct-out GdkColor)))
|
||||
|
|
|
|||
|
|
@ -130,6 +130,7 @@
|
|||
(lambda (gtk event)
|
||||
(let ([wx (gtk->wx gtk)])
|
||||
(when wx
|
||||
(send wx focus-change #t)
|
||||
(send (send wx get-top-win) on-focus-child #t)
|
||||
(queue-window-event wx (lambda () (send wx on-set-focus))))
|
||||
#f)))
|
||||
|
|
@ -138,6 +139,7 @@
|
|||
(lambda (gtk event)
|
||||
(let ([wx (gtk->wx gtk)])
|
||||
(when wx
|
||||
(send wx focus-change #f)
|
||||
(send (send wx get-top-win) on-focus-child #f)
|
||||
(queue-window-event wx (lambda () (send wx on-kill-focus))))
|
||||
#f)))
|
||||
|
|
@ -180,60 +182,71 @@
|
|||
(let ([wx (gtk->wx gtk)])
|
||||
(and
|
||||
wx
|
||||
(let* ([modifiers (if scroll?
|
||||
(GdkEventScroll-state event)
|
||||
(GdkEventKey-state event))]
|
||||
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
|
||||
[keyval->code (lambda (kv)
|
||||
(or
|
||||
(map-key-code kv)
|
||||
(integer->char (gdk_keyval_to_unicode kv))))]
|
||||
[key-code (if scroll?
|
||||
(if (= (GdkEventScroll-direction event)
|
||||
GDK_SCROLL_UP)
|
||||
'wheel-up
|
||||
'wheel-down)
|
||||
(keyval->code (GdkEventKey-keyval event)))]
|
||||
[k (new key-event%
|
||||
[key-code key-code]
|
||||
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
|
||||
[control-down (bit? modifiers GDK_CONTROL_MASK)]
|
||||
[meta-down (bit? modifiers GDK_MOD1_MASK)]
|
||||
[alt-down (bit? modifiers GDK_META_MASK)]
|
||||
[x 0]
|
||||
[y 0]
|
||||
[time-stamp (if scroll?
|
||||
(GdkEventScroll-time event)
|
||||
(GdkEventKey-time event))]
|
||||
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
|
||||
(when (or (and (not scroll?)
|
||||
(let-values ([(s ag sag cl) (get-alts event)]
|
||||
[(keyval->code*) (lambda (v)
|
||||
(and v
|
||||
(let ([c (keyval->code v)])
|
||||
(and (not (equal? #\u0000 c))
|
||||
c))))])
|
||||
(let ([s (keyval->code* s)]
|
||||
[ag (keyval->code* ag)]
|
||||
[sag (keyval->code* sag)]
|
||||
[cl (keyval->code* cl)])
|
||||
(when s (send k set-other-shift-key-code s))
|
||||
(when ag (send k set-other-altgr-key-code ag))
|
||||
(when sag (send k set-other-shift-altgr-key-code sag))
|
||||
(when cl (send k set-other-caps-key-code cl))
|
||||
(or s ag sag cl))))
|
||||
(not (equal? #\u0000 key-code)))
|
||||
(unless (or scroll? down?)
|
||||
;; swap altenate with main
|
||||
(send k set-key-release-code (send k get-key-code))
|
||||
(send k set-key-code 'release))
|
||||
(if (send wx handles-events? gtk)
|
||||
(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)))))))
|
||||
(let ([im-str (if scroll?
|
||||
'none
|
||||
;; Result from `filter-key-event' is one of
|
||||
;; - #f => drop the event
|
||||
;; - 'none => no replacement; handle as usual
|
||||
;; - a string => use as the keycode
|
||||
(send wx filter-key-event event))])
|
||||
(when im-str
|
||||
(let* ([modifiers (if scroll?
|
||||
(GdkEventScroll-state event)
|
||||
(GdkEventKey-state event))]
|
||||
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
|
||||
[keyval->code (lambda (kv)
|
||||
(or
|
||||
(map-key-code kv)
|
||||
(integer->char (gdk_keyval_to_unicode kv))))]
|
||||
[key-code (if scroll?
|
||||
(if (= (GdkEventScroll-direction event)
|
||||
GDK_SCROLL_UP)
|
||||
'wheel-up
|
||||
'wheel-down)
|
||||
(keyval->code (GdkEventKey-keyval event)))]
|
||||
[k (new key-event%
|
||||
[key-code (if (and (string? im-str)
|
||||
(= 1 (string-length im-str)))
|
||||
(string-ref im-str 0)
|
||||
key-code)]
|
||||
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
|
||||
[control-down (bit? modifiers GDK_CONTROL_MASK)]
|
||||
[meta-down (bit? modifiers GDK_MOD1_MASK)]
|
||||
[alt-down (bit? modifiers GDK_META_MASK)]
|
||||
[x 0]
|
||||
[y 0]
|
||||
[time-stamp (if scroll?
|
||||
(GdkEventScroll-time event)
|
||||
(GdkEventKey-time event))]
|
||||
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
|
||||
(when (or (and (not scroll?)
|
||||
(let-values ([(s ag sag cl) (get-alts event)]
|
||||
[(keyval->code*) (lambda (v)
|
||||
(and v
|
||||
(let ([c (keyval->code v)])
|
||||
(and (not (equal? #\u0000 c))
|
||||
c))))])
|
||||
(let ([s (keyval->code* s)]
|
||||
[ag (keyval->code* ag)]
|
||||
[sag (keyval->code* sag)]
|
||||
[cl (keyval->code* cl)])
|
||||
(when s (send k set-other-shift-key-code s))
|
||||
(when ag (send k set-other-altgr-key-code ag))
|
||||
(when sag (send k set-other-shift-altgr-key-code sag))
|
||||
(when cl (send k set-other-caps-key-code cl))
|
||||
(or s ag sag cl))))
|
||||
(not (equal? #\u0000 key-code)))
|
||||
(unless (or scroll? down?)
|
||||
;; swap altenate with main
|
||||
(send k set-key-release-code (send k get-key-code))
|
||||
(send k set-key-code 'release))
|
||||
(if (send wx handles-events? gtk)
|
||||
(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-signal-handler connect-button-press "button-press-event"
|
||||
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
|
||||
|
|
@ -562,6 +575,9 @@
|
|||
(define/public (on-set-focus) (void))
|
||||
(define/public (on-kill-focus) (void))
|
||||
|
||||
(define/public (focus-change on?) (void))
|
||||
(define/public (filter-key-event e) 'none)
|
||||
|
||||
(define/private (pre-event-refresh)
|
||||
;; Since we break the connection between the
|
||||
;; Gtk queue and event handling, we
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user