: mouse-event>gesture ( event -- modifiers button loc )
[ event-modifiers ] [ button>> ] [ event-loc ] tri ;
- [ loc>> ] [
- parent>> [ gadget-location ] [ { 0 0 } ] if*
- ] bi v+ ;
+: gadget-location ( gadget -- loc )
++ [ loc>> ] [ parent>> [ gadget-location v+ ] when* ] bi ;
+
+: focusable-editor ( world -- editor/f )
+ focusable-child dup editor? [ drop f ] unless ;
+
+: get-cursor-location ( editor -- GdkRectangle )
+ [ [ gadget-location ] [ caret-loc ] bi v+ first2 ]
+ [ line-height ] bi 0 swap GdkRectangle <struct-boa> ;
+
+: update-im-cursor-location ( world -- )
+ dup focusable-editor [
+ [ handle>> im-context>> ] [ get-cursor-location ] bi*
+ gtk_im_context_set_cursor_location
+ ] [ drop ] if* ;
+
: on-motion ( sender event user-data -- result )
- drop swap [
- [ GdkEventMotion memory>struct event-loc ] dip window
- move-hand fire-motion
- ] [ window update-im-cursor-location ] bi t ;
+ drop swap
+ [ GdkEventMotion memory>struct event-loc ] dip window
+ move-hand fire-motion t ;
: on-enter ( sender event user-data -- result )
on-motion ;
drop swap [
GdkEventScroll memory>struct
[ scroll-direction ] [ event-loc ] bi
- ] dip window
- [ send-scroll ] [ update-im-cursor-location ] bi t ;
+ ] dip window send-scroll t ;
- : key-sym ( event -- sym action? )
- keyval>> dup action-key-codes at
- [ t ] [ gdk_keyval_to_unicode 1string f ] ?if ;
+ : key-sym ( event -- sym/f action? )
+ keyval>> dup action-key-codes at [ t ]
+ [ gdk_keyval_to_unicode [ f ] [ 1string ] if-zero f ] ?if ;
- : key-event>gesture ( event -- modifiers sym action? )
+ : key-event>gesture ( event -- mods sym/f action? )
+ GdkEventKey memory>struct
[ event-modifiers ] [ key-sym ] bi ;
- : valid-input? ( string gesture -- ? )
- over empty? [ 2drop f ] [
- mods>> { f { S+ } } member? [
- [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
- ] [
- [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
- ] if
- ] if ;
-
- :: on-key-press ( sender event user-data -- result )
- sender window :> world
- world handle>> im-context>> :> im-context
- im-context event gtk_im_context_filter_keypress
- [
- event GdkEventKey memory>struct :> ev
- ev key-event>gesture <key-down> :> gesture
- gesture world propagate-key-gesture
- ev keyval>> gdk_keyval_to_unicode 1string dup
- gesture valid-input?
- [ world user-input ] [ drop ] if
- ] unless
- world update-im-cursor-location t ;
-
- :: on-key-release ( sender event user-data -- result )
- sender window :> world
- world handle>> im-context>> event gtk_im_context_filter_keypress
- [
- event GdkEventKey memory>struct
- key-event>gesture <key-up>
- world propagate-key-gesture
- ] unless
- world update-im-cursor-location t ;
-: send-key-gesture ( win gesture -- )
- swap window propagate-key-gesture ;
++: handle-key-gesture ( key-gesture world -- )
++ [ propagate-key-gesture ]
++ [ update-im-cursor-location ] bi ;
+
+ : on-key-press ( sender event user-data -- result )
- drop key-event>gesture over
- [ <key-down> send-key-gesture ] [ 3drop drop ] if t ;
++ drop swap [ key-event>gesture <key-down> ] [ window ] bi*
++ handle-key-gesture t ;
+
+ : on-key-release ( sender event user-data -- result )
- drop key-event>gesture over
- [ <key-up> send-key-gesture ] [ 3drop drop ] if t ;
++ drop swap [ key-event>gesture <key-up> ] [ window ] bi*
++ handle-key-gesture t ;
: on-focus-in ( sender event user-data -- result )
- 2drop window [ focus-world ]
- [ handle>> im-context>> gtk_im_context_focus_in ]
- [ update-im-cursor-location ] tri
- f ;
+ 2drop window focus-world t ;
: on-focus-out ( sender event user-data -- result )
- 2drop window [ unfocus-world ]
- [ handle>> im-context>> gtk_im_context_focus_out ]
- [ update-im-cursor-location ] tri
- f ;
+ 2drop window unfocus-world t ;
: on-expose ( sender event user-data -- result )
2drop window relayout t ;
win "delete-event" [ on-delete yield ]
GtkWidget:delete-event connect-signal ;
- : connect-im-signals ( im-context -- )
- {
- [
- "commit" [ on-commit yield ]
- GtkIMContext:commit connect-signal
- ] [
- "retrieve-surrounding" [ on-retrieve-surrounding yield ]
- GtkIMContext:retrieve-surrounding connect-signal
- ] [
- "delete-surrounding" [ on-delete-surrounding yield ]
- GtkIMContext:delete-surrounding connect-signal
- ]
- } cleave ;
-: on-key-event-for-im ( sender event user-data -- result )
- swap gtk_im_context_filter_keypress 2drop f ;
-
-: on-focus-out-for-im ( sender event user-data -- result )
- 2nip gtk_im_context_reset f ;
-
-: on-destroy-for-im ( sender user-data -- result )
- nip g_object_unref f ;
-
-: on-im-commit ( sender str user_data -- )
- [ drop ] [ utf8 alien>string ] [ window ] tri* user-input ;
-
-:: configure-im ( win -- )
- gtk_im_context_simple_new :> im
- im win gtk_im_context_set_client_window
++: on-retrieve-surrounding ( im-context user-data -- ? )
++ window focusable-editor [| im-context editor |
++ editor editor-caret first2 :> ( x y )
++ im-context
++ y editor editor-line utf8 string>alien
++ -1 x
++ gtk_im_context_set_surrounding t
++ ] [ drop f ] if* ;
++
++:: on-delete-surrounding ( im-context offset n user-data -- ? )
++ user-data window :> world
++ world focusable-editor [| editor |
++ editor editor-caret first2 :> ( x y )
++ x offset + y [ 2array ] [ [ n + ] dip 2array ] 2bi
++ editor remove-doc-range
++ world update-im-cursor-location
++ t
++ ] [ f ] if* ;
++
++: on-commit ( sender str user_data -- )
++ [ drop ] [ utf8 alien>string ] [ window ] tri*
++ [ user-input ]
++ [ [ f swap key-down boa ] dip handle-key-gesture ] 2bi ;
++
++! has to be called before the window signal handler
++: im-on-key-event ( sender event user-data -- result )
++ [ drop ] 2dip swap gtk_im_context_filter_keypress ;
++
++: im-on-focus-in ( sender event user-data -- result )
++ 2drop window
++ [ handle>> im-context>> gtk_im_context_focus_in ]
++ [ update-im-cursor-location ] bi f ;
++
++: im-on-focus-out ( sender event user-data -- result )
++ 2drop window
++ [ handle>> im-context>> gtk_im_context_focus_out ]
++ [ update-im-cursor-location ] bi f ;
++
++: im-on-motion ( sender event user-data -- result )
++ 2drop window update-im-cursor-location f ;
++
++: im-on-destroy ( sender user-data -- result )
++ nip [ f gtk_im_context_set_client_window ]
++ [ g_object_unref ] bi f ;
++
++:: configure-im ( win im -- )
++ im win gtk_widget_get_window gtk_im_context_set_client_window
++ im f gtk_im_context_set_use_preedit
+
- im "commit" [ on-im-commit yield ]
++ im "commit" [ on-commit yield ]
+ GtkIMContext:commit win connect-signal-with-data
++ im "retrieve-surrounding" [ on-retrieve-surrounding yield ]
++ GtkIMContext:retrieve-surrounding win connect-signal-with-data
++ im "delete-surrounding" [ on-delete-surrounding yield ]
++ GtkIMContext:delete-surrounding win connect-signal-with-data
+
- win "key-press-event" [ on-key-event-for-im ]
++ win "key-press-event" [ im-on-key-event yield ]
+ GtkWidget:key-press-event im connect-signal-with-data
- win "key-release-event" [ on-key-event-for-im ]
++ win "key-release-event" [ im-on-key-event yield ]
+ GtkWidget:key-release-event im connect-signal-with-data
- win "focus-out-event" [ on-focus-out-for-im ]
++ win "focus-in-event" [ im-on-focus-in yield ]
+ GtkWidget:focus-out-event im connect-signal-with-data
- win "destroy" [ on-destroy-for-im ]
++ win "focus-out-event" [ im-on-focus-out yield ]
++ GtkWidget:focus-out-event im connect-signal-with-data
++ win "motion-notify-event" [ im-on-motion yield ]
++ GtkWidget:motion-notify-event connect-signal
++ win "enter-notify-event" [ im-on-motion yield ]
++ GtkWidget:enter-notify-event connect-signal
++ win "scroll-event" [ im-on-motion yield ]
++ GtkWidget:scroll-event connect-signal
++ win "destroy" [ im-on-destroy yield ]
+ GtkObject:destroy im connect-signal-with-data ;
CONSTANT: window-controls>decor-flags
H{
M:: gtk-ui-backend (open-window) ( world -- )
GTK_WINDOW_TOPLEVEL gtk_window_new :> win
- gtk_im_multicontext_new :> im-context
-
- im-context f gtk_im_context_set_use_preedit
++ gtk_im_multicontext_new :> im
- win im-context <window-handle> world handle<<
- world win [ <window-handle> >>handle drop ]
- [ register-window ] 2bi
++ win im <window-handle> world handle<<
+
+ world win register-window
win world [ window-loc>> auto-position ]
[ dim>> first2 gtk_window_set_default_size ] 2bi
world setup-gl drop
-
- win connect-signals
- im-context connect-im-signals
-
+
- win configure-im
-
- win connect-signals
-
win gtk_widget_realize
win world window-controls>> configure-window-controls
-
- im-context win gtk_widget_get_window
- gtk_im_context_set_client_window
+
++ win im configure-im
++ win connect-signals
+
win gtk_widget_show_all ;
M: gtk-ui-backend (close-window) ( handle -- )
- [ im-context>> f gtk_im_context_set_client_window ]
- [ window>> [ gtk_widget_destroy ] [ unregister-window ] bi ] bi
- window>> [ unregister-window ] [ gtk_widget_destroy ] bi
++ window>> [ gtk_widget_destroy ] [ unregister-window ] bi
event-loop? [ gtk_main_quit ] unless ;
M: gtk-ui-backend set-title