basis/ui/backend/gtk/gtk.factor

   1 ! Copyright (C) 2010 Anton Gorenko, Philipp Brüschweiler.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.accessors alien.c-types alien.data
   4 alien.strings arrays assocs classes.struct command-line
   5 destructors gdk.ffi gdk.gl.ffi gdk.pixbuf.ffi glib.ffi
   6 gobject.ffi gtk.ffi gtk.gl.ffi io.backend
   7 io.backend.unix.multiplexers io.encodings.binary
   8 io.encodings.utf8 io.files io.thread kernel libc literals
   9 locals math math.bitwise math.order math.vectors namespaces
  10 sequences strings system threads ui ui.backend ui.clipboards
  11 ui.commands ui.event-loop ui.gadgets ui.gadgets.editors
  12 ui.gadgets.menus ui.gadgets.private ui.gadgets.worlds
  13 ui.gestures ui.pixel-formats ui.pixel-formats.private
  14 ui.private ;
  15 IN: ui.backend.gtk
  16
  17 SINGLETON: gtk-ui-backend
  18
  19 TUPLE: handle ;
  20 TUPLE: window-handle < handle window fullscreen? im-context im-menu ;
  21
  22 : <window-handle> ( window im-context -- window-handle )
  23     window-handle new
  24         swap >>im-context
  25         swap >>window ;
  26
  27 TUPLE: gtk-clipboard handle ;
  28
  29 C: <gtk-clipboard> gtk-clipboard
  30
  31 PIXEL-FORMAT-ATTRIBUTE-TABLE: gl-config-attribs ${ GDK_GL_USE_GL GDK_GL_RGBA } H{
  32     { double-buffered ${ GDK_GL_DOUBLEBUFFER } }
  33     { stereo ${ GDK_GL_STEREO } }
  34     ! { offscreen ${ GDK_GL_DRAWABLE_TYPE 2 } }
  35     ! { fullscreen ${ GDK_GL_DRAWABLE_TYPE 1 } }
  36     ! { windowed ${ GDK_GL_DRAWABLE_TYPE 1 } }
  37     { color-bits ${ GDK_GL_BUFFER_SIZE } }
  38     { red-bits ${ GDK_GL_RED_SIZE } }
  39     { green-bits ${ GDK_GL_GREEN_SIZE } }
  40     { blue-bits ${ GDK_GL_BLUE_SIZE } }
  41     { alpha-bits ${ GDK_GL_ALPHA_SIZE } }
  42     { accum-red-bits ${ GDK_GL_ACCUM_RED_SIZE } }
  43     { accum-green-bits ${ GDK_GL_ACCUM_GREEN_SIZE } }
  44     { accum-blue-bits ${ GDK_GL_ACCUM_BLUE_SIZE } }
  45     { accum-alpha-bits ${ GDK_GL_ACCUM_ALPHA_SIZE } }
  46     { depth-bits ${ GDK_GL_DEPTH_SIZE } }
  47     { stencil-bits ${ GDK_GL_STENCIL_SIZE } }
  48     { aux-buffers ${ GDK_GL_AUX_BUFFERS } }
  49     { sample-buffers ${ GDK_GL_SAMPLE_BUFFERS } }
  50     { samples ${ GDK_GL_SAMPLES } }
  51 }
  52
  53 M: gtk-ui-backend (make-pixel-format)
  54     nip >gl-config-attribs-int-array gdk_gl_config_new ;
  55
  56 M: gtk-ui-backend (free-pixel-format)
  57     handle>> g_object_unref ;
  58
  59 M: gtk-ui-backend (pixel-format-attribute)
  60     [ handle>> ] [ >gl-config-attribs ] bi*
  61     { int } [ gdk_gl_config_get_attrib drop ]
  62     with-out-parameters ;
  63
  64 CONSTANT: events-mask
  65     flags{
  66         GDK_POINTER_MOTION_MASK
  67         GDK_POINTER_MOTION_HINT_MASK
  68         GDK_ENTER_NOTIFY_MASK
  69         GDK_LEAVE_NOTIFY_MASK
  70         GDK_BUTTON_PRESS_MASK
  71         GDK_BUTTON_RELEASE_MASK
  72         GDK_KEY_PRESS_MASK
  73         GDK_KEY_RELEASE_MASK
  74         GDK_FOCUS_CHANGE_MASK
  75     }
  76
  77 CONSTANT: modifiers
  78     {
  79         { S+ $ GDK_SHIFT_MASK }
  80         { C+ $ GDK_CONTROL_MASK }
  81         { A+ $ GDK_MOD1_MASK }
  82     }
  83
  84 CONSTANT: action-key-codes
  85     H{
  86         { $ GDK_BackSpace "BACKSPACE" }
  87         { $ GDK_Tab "TAB" }
  88         { $ GDK_Return "RET" }
  89         { $ GDK_KP_Enter "ENTER" }
  90         { $ GDK_Escape "ESC" }
  91         { $ GDK_Delete "DELETE" }
  92         { $ GDK_Home "HOME" }
  93         { $ GDK_Left "LEFT" }
  94         { $ GDK_Up "UP" }
  95         { $ GDK_Right "RIGHT" }
  96         { $ GDK_Down "DOWN" }
  97         { $ GDK_Page_Up "PAGE_UP" }
  98         { $ GDK_Page_Down "PAGE_DOWN" }
  99         { $ GDK_End "END" }
 100         { $ GDK_Begin "BEGIN" }
 101         { $ GDK_F1 "F1" }
 102         { $ GDK_F2 "F2" }
 103         { $ GDK_F3 "F3" }
 104         { $ GDK_F4 "F4" }
 105         { $ GDK_F5 "F5" }
 106         { $ GDK_F6 "F6" }
 107         { $ GDK_F7 "F7" }
 108         { $ GDK_F8 "F8" }
 109         { $ GDK_F9 "F9" }
 110         { $ GDK_F10 "F10" }
 111         { $ GDK_F11 "F11" }
 112         { $ GDK_F12 "F12" }
 113     }
 114
 115 : event-modifiers ( event -- seq )
 116     state>> modifiers modifier ;
 117
 118 : event-loc ( event -- loc )
 119     [ x>> ] [ y>> ] bi [ >fixnum ] bi@ 2array ;
 120
 121 : event-dim ( event -- dim )
 122     [ width>> ] [ height>> ] bi 2array ;
 123
 124 : scroll-direction ( event -- pair )
 125     direction>> {
 126         { $ GDK_SCROLL_UP { 0 -1 } }
 127         { $ GDK_SCROLL_DOWN { 0 1 } }
 128         { $ GDK_SCROLL_LEFT { -1 0 } }
 129         { $ GDK_SCROLL_RIGHT { 1 0 } }
 130     } at ;
 131
 132 : mouse-event>gesture ( event -- modifiers button loc )
 133     [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
 134
 135 : on-motion ( sender event user-data -- result )
 136     drop swap
 137     [ GdkEventMotion memory>struct event-loc ] dip window
 138     move-hand fire-motion t ;
 139
 140 : on-enter ( sender event user-data -- result )
 141     on-motion ;
 142
 143 : on-leave ( sender event user-data -- result )
 144     3drop forget-rollover t ;
 145
 146 : on-button-press ( sender event user-data -- result )
 147     drop swap [
 148         GdkEventButton memory>struct
 149         mouse-event>gesture [ <button-down> ] dip
 150     ] dip window send-button-down t ;
 151
 152 : on-button-release ( sender event user-data -- result )
 153     drop swap [
 154         GdkEventButton memory>struct
 155         mouse-event>gesture [ <button-up> ] dip
 156     ] dip window send-button-up t ;
 157
 158 : on-scroll ( sender event user-data -- result )
 159     drop swap [
 160         GdkEventScroll memory>struct
 161         [ scroll-direction ] [ event-loc ] bi
 162     ] dip window send-scroll t ;
 163
 164 : key-sym ( event -- sym/f action? )
 165     keyval>> dup action-key-codes at [ t ]
 166     [ gdk_keyval_to_unicode [ f ] [ 1string ] if-zero f ] ?if ;
 167
 168 : key-event>gesture ( event -- mods sym/f action? )
 169     GdkEventKey memory>struct
 170     [ event-modifiers ] [ key-sym ] bi ;
 171
 172 : on-key-press ( sender event user-data -- result )
 173     drop swap [ key-event>gesture <key-down> ] [ window ] bi*
 174     propagate-key-gesture t ;
 175
 176 : on-key-release ( sender event user-data -- result )
 177     drop swap [ key-event>gesture <key-up> ] [ window ] bi*
 178     propagate-key-gesture t ;
 179
 180 : on-focus-in ( sender event user-data -- result )
 181     2drop window focus-world t ;
 182
 183 : on-focus-out ( sender event user-data -- result )
 184     2drop window unfocus-world t ;
 185
 186 : on-expose ( sender event user-data -- result )
 187     2drop window relayout t ;
 188
 189 : on-configure ( sender event user-data -- result )
 190     drop [ window ] dip GdkEventConfigure memory>struct
 191     [ event-loc >>window-loc ] [ event-dim >>dim  ] bi
 192     relayout-1 f ;
 193
 194 : on-delete ( sender event user-data -- result )
 195     2drop window ungraft t ;
 196
 197 : init-clipboard ( -- )
 198     selection "PRIMARY"
 199     clipboard "CLIPBOARD"
 200     [
 201         utf8 string>alien gdk_atom_intern_static_string
 202         gtk_clipboard_get <gtk-clipboard> swap set-global
 203     ] 2bi@ ;
 204
 205 : io-source-prepare ( source timeout -- result )
 206     2drop f ;
 207
 208 : io-source-check ( source -- result )
 209     poll_fds>> 0 g_slist_nth_data GPollFD memory>struct
 210     revents>> 0 = not ;
 211
 212 : io-source-dispatch ( source callback user_data -- result )
 213      3drop
 214      0 mx get wait-for-events
 215      yield t ;
 216
 217 CONSTANT: poll-fd-events
 218     flags{
 219         G_IO_IN
 220         G_IO_OUT
 221         G_IO_PRI
 222         G_IO_ERR
 223         G_IO_HUP
 224         G_IO_NVAL
 225     }
 226
 227 : create-poll-fd ( -- poll-fd )
 228     GPollFD malloc-struct &free
 229         mx get fd>> >>fd
 230         poll-fd-events >>events ;
 231
 232 HOOK: init-io-event-source io-backend ( -- )
 233
 234 M: f init-io-event-source ;
 235 M: c-io-backend init-io-event-source ;
 236
 237 M: object init-io-event-source
 238     GSourceFuncs malloc-struct &free
 239         [ io-source-prepare ] GSourceFuncsPrepareFunc >>prepare
 240         [ io-source-check ] GSourceFuncsCheckFunc >>check
 241         [ io-source-dispatch ] GSourceFuncsDispatchFunc >>dispatch
 242     GSource heap-size g_source_new &g_source_unref
 243     [ create-poll-fd g_source_add_poll ]
 244     [ f g_source_attach drop ] bi ;
 245
 246 SYMBOL: next-timeout
 247
 248 : set-timeout*-value ( alien value -- )
 249     swap 0 set-alien-signed-4 ; inline
 250
 251 : timeout-prepare ( source timeout* -- result )
 252     nip next-timeout get-global nano-count [-]
 253     [ 1,000,000 /i set-timeout*-value ] keep 0 = ;
 254
 255 : timeout-check ( source -- result )
 256     drop next-timeout get-global nano-count [-] 0 = ;
 257
 258 : timeout-dispatch ( source callback user_data -- result )
 259     3drop sleep-time [ 1,000,000,000 ] unless* nano-count +
 260     next-timeout set-global
 261     yield t ;
 262
 263 : init-timeout ( -- )
 264     GSourceFuncs malloc-struct &free
 265         [ timeout-prepare ] GSourceFuncsPrepareFunc >>prepare
 266         [ timeout-check ] GSourceFuncsCheckFunc >>check
 267         [ timeout-dispatch ] GSourceFuncsDispatchFunc >>dispatch
 268     GSource heap-size g_source_new &g_source_unref
 269     f g_source_attach drop
 270     nano-count next-timeout set-global ;
 271
 272 ! This word gets replaced when deploying. See 'Vocabulary icons'
 273 ! in the docs and tools.deploy.shaker.gtk-icon
 274 : get-icon-data ( -- byte-array )
 275     "resource:misc/icons/Factor_48x48.png" binary file-contents ;
 276
 277 : load-icon ( -- )
 278     get-icon-data [
 279         data>GInputStream &g_object_unref
 280         GInputStream>GdkPixbuf gtk_window_set_default_icon
 281     ] with-destructors ;
 282
 283 M: gtk-ui-backend (with-ui)
 284     [
 285         f f gtk_init
 286         f f gtk_gl_init
 287         load-icon
 288         init-clipboard
 289         start-ui
 290         stop-io-thread
 291         [
 292             init-io-event-source
 293             init-timeout
 294             gtk_main
 295         ] with-destructors
 296     ] ui-running ;
 297
 298 : connect-signal-with-data ( object signal-name callback data -- )
 299     [ utf8 string>alien ] 2dip g_signal_connect drop ;
 300
 301 : connect-signal ( object signal-name callback -- )
 302     f connect-signal-with-data ;
 303
 304 :: connect-signals ( win -- )
 305     win events-mask gtk_widget_add_events
 306
 307     win "expose-event" [ on-expose yield ]
 308     GtkWidget:expose-event connect-signal
 309     win "configure-event" [ on-configure yield ]
 310     GtkWidget:configure-event connect-signal
 311     win "motion-notify-event" [ on-motion yield ]
 312     GtkWidget:motion-notify-event connect-signal
 313     win "leave-notify-event" [ on-leave yield ]
 314     GtkWidget:leave-notify-event connect-signal
 315     win "enter-notify-event" [ on-enter yield ]
 316     GtkWidget:enter-notify-event connect-signal
 317     win "button-press-event" [ on-button-press yield ]
 318     GtkWidget:button-press-event connect-signal
 319     win "button-release-event" [ on-button-release yield ]
 320     GtkWidget:button-release-event connect-signal
 321     win "scroll-event" [ on-scroll yield ]
 322     GtkWidget:scroll-event connect-signal
 323     win "key-press-event" [ on-key-press yield ]
 324     GtkWidget:key-press-event connect-signal
 325     win "key-release-event" [ on-key-release yield ]
 326     GtkWidget:key-release-event connect-signal
 327     win "focus-in-event" [ on-focus-in yield ]
 328     GtkWidget:focus-in-event connect-signal
 329     win "focus-out-event" [ on-focus-out yield ]
 330     GtkWidget:focus-out-event connect-signal
 331     win "delete-event" [ on-delete yield ]
 332     GtkWidget:delete-event connect-signal ;
 333
 334 ! ----------------------
 335
 336 GENERIC: support-input-methods? ( gadget -- ? )
 337 GENERIC: get-cursor-surrounding ( gadget -- text cursor-pos )
 338 GENERIC: delete-cursor-surrounding ( offset count gadget -- )
 339 GENERIC: set-preedit-string ( str cursor-pos gadget -- )
 340 GENERIC: get-cursor-loc&dim ( gadget -- loc dim )
 341
 342 M: gadget support-input-methods? drop f ;
 343
 344 M: editor support-input-methods? drop t ;
 345
 346 M: editor get-cursor-surrounding
 347     dup editor-caret first2 [ swap editor-line ] dip ;
 348
 349 M: editor delete-cursor-surrounding
 350     3drop ;
 351
 352 M: editor set-preedit-string
 353     nip dup [ editor-caret ] keep
 354     [ user-input* drop ] 2dip
 355     set-caret ;
 356
 357 M: editor get-cursor-loc&dim
 358     [ caret-loc ] [ caret-dim ] bi ;
 359
 360 ! ----------------------
 361
 362 : on-retrieve-surrounding ( im-context win -- ? )
 363     window world-focus dup support-input-methods? [
 364         get-cursor-surrounding [ utf8 string>alien -1 ] dip
 365         gtk_im_context_set_surrounding t
 366     ] [ 2drop f ] if ;
 367
 368 : on-delete-surrounding ( im-context offset n win -- ? )
 369     window world-focus dup support-input-methods?
 370     [ delete-cursor-surrounding t ] [ 3drop f ] if nip ;
 371
 372 : get-preedit-string ( im-context -- str cursor-pos )
 373     { void* int } [ f swap gtk_im_context_get_preedit_string ]
 374     with-out-parameters
 375     [ [ utf8 alien>string ] [ g_free ] bi ] dip ;
 376
 377 : on-preedit-changed ( im-context user-data -- )
 378     window world-focus dup support-input-methods? [
 379         [ get-preedit-string ] dip set-preedit-string
 380     ] [ 2drop ] if ;
 381
 382 : on-commit ( sender str user_data -- )
 383     [ drop ] [ utf8 alien>string ] [ window ] tri* user-input ;
 384
 385 : gadget-location ( gadget -- loc )
 386     [ loc>> ] [ parent>> [ gadget-location v+ ] when* ] bi ;
 387
 388 : gadget-cursor-location ( gadget -- rectangle )
 389     [ gadget-location ] [ get-cursor-loc&dim ] bi [ v+ ] dip
 390     [ first2 ] bi@ GdkRectangle <struct-boa> ;
 391
 392 : update-cursor-location ( im-context gadget -- )
 393     gadget-cursor-location gtk_im_context_set_cursor_location ;
 394
 395 ! has to be called before the window signal handler
 396 :: im-on-key-event ( sender event im-context -- result )
 397     sender window world-focus :> gadget
 398     gadget support-input-methods? [
 399         im-context gadget update-cursor-location
 400         im-context event gtk_im_context_filter_keypress
 401     ] [ im-context gtk_im_context_reset f ] if ;
 402
 403 : im-on-focus-in ( sender event user-data -- result )
 404     2drop window handle>> im-context>>
 405     [ gtk_im_context_focus_in ] [ gtk_im_context_reset ] bi f ;
 406
 407 : im-on-focus-out ( sender event user-data -- result )
 408     2drop window handle>> im-context>>
 409     [ gtk_im_context_focus_out ] [ gtk_im_context_reset ] bi f ;
 410
 411 : im-on-destroy ( sender user-data -- )
 412     nip [ f gtk_im_context_set_client_window ]
 413     [ g_object_unref ] bi ;
 414
 415 ! for testing only
 416
 417 : com-input-method ( world -- )
 418     find-world handle>> im-menu>> f f f f 0
 419     gtk_get_current_event_time gtk_menu_popup ;
 420
 421 : im-menu ( world -- )
 422     { com-input-method } show-commands-menu ;
 423
 424 editor "input-method" f  {
 425     { T{ button-down f { S+ C+ } 3 } im-menu }
 426 } define-command-map
 427
 428 ! --------
 429
 430 :: configure-im ( win im -- )
 431     im win gtk_widget_get_window gtk_im_context_set_client_window
 432     im f gtk_im_context_set_use_preedit
 433
 434     gtk_menu_new :> menu
 435     im menu gtk_im_multicontext_append_menuitems
 436     menu win window handle>> im-menu<<
 437
 438     im "commit" [ on-commit yield ]
 439     GtkIMContext:commit win connect-signal-with-data
 440     im "retrieve-surrounding" [ on-retrieve-surrounding yield ]
 441     GtkIMContext:retrieve-surrounding win connect-signal-with-data
 442     im "delete-surrounding" [ on-delete-surrounding yield ]
 443     GtkIMContext:delete-surrounding win connect-signal-with-data
 444     im "preedit-changed" [ on-preedit-changed yield ]
 445     GtkIMContext:preedit-changed win connect-signal-with-data
 446
 447     win "key-press-event" [ im-on-key-event yield ]
 448     GtkWidget:key-press-event im connect-signal-with-data
 449     win "key-release-event" [ im-on-key-event yield ]
 450     GtkWidget:key-release-event im connect-signal-with-data
 451     win "focus-in-event" [ im-on-focus-in yield ]
 452     GtkWidget:focus-out-event im connect-signal-with-data
 453     win "focus-out-event" [ im-on-focus-out yield ]
 454     GtkWidget:focus-out-event im connect-signal-with-data
 455     win "destroy" [ im-on-destroy yield ]
 456     GtkObject:destroy im connect-signal-with-data ;
 457
 458 CONSTANT: window-controls>decor-flags
 459     H{
 460         { close-button 0 }
 461         { minimize-button $ GDK_DECOR_MINIMIZE }
 462         { maximize-button $ GDK_DECOR_MAXIMIZE }
 463         { resize-handles $ GDK_DECOR_RESIZEH }
 464         { small-title-bar $ GDK_DECOR_TITLE }
 465         { normal-title-bar $ GDK_DECOR_TITLE }
 466         { textured-background 0 }
 467     }
 468
 469 CONSTANT: window-controls>func-flags
 470     H{
 471         { close-button $ GDK_FUNC_CLOSE }
 472         { minimize-button $ GDK_FUNC_MINIMIZE }
 473         { maximize-button $ GDK_FUNC_MAXIMIZE }
 474         { resize-handles $ GDK_FUNC_RESIZE }
 475         { small-title-bar 0 }
 476         { normal-title-bar 0 }
 477         { textured-background 0 }
 478     }
 479
 480 : configure-window-controls ( win controls -- )
 481     [
 482         small-title-bar swap member-eq?
 483         GDK_WINDOW_TYPE_HINT_UTILITY GDK_WINDOW_TYPE_HINT_NORMAL ?
 484         gtk_window_set_type_hint
 485     ] [
 486         [ gtk_widget_get_window ] dip
 487         window-controls>decor-flags symbols>flags
 488         GDK_DECOR_BORDER bitor gdk_window_set_decorations
 489     ] [
 490         [ gtk_widget_get_window ] dip
 491         window-controls>func-flags symbols>flags
 492         GDK_FUNC_MOVE bitor gdk_window_set_functions
 493     ] 2tri ;
 494
 495 : setup-gl ( world -- ? )
 496     [
 497         [ handle>> window>> ] [ handle>> ] bi*
 498         f t GDK_GL_RGBA_TYPE gtk_widget_set_gl_capability
 499     ] with-world-pixel-format ;
 500
 501 : auto-position ( win loc -- )
 502     dup { 0 0 } = [
 503         drop dup window topmost-window =
 504         GTK_WIN_POS_CENTER GTK_WIN_POS_NONE ?
 505         gtk_window_set_position
 506     ] [ first2 gtk_window_move ] if ;
 507
 508 M:: gtk-ui-backend (open-window) ( world -- )
 509     GTK_WINDOW_TOPLEVEL gtk_window_new :> win
 510     gtk_im_multicontext_new :> im
 511
 512     win im <window-handle> world handle<<
 513
 514     world win register-window
 515
 516     win world [ window-loc>> auto-position ]
 517     [ dim>> first2 gtk_window_set_default_size ] 2bi
 518
 519     world setup-gl drop
 520
 521     win gtk_widget_realize
 522     win world window-controls>> configure-window-controls
 523
 524     win im configure-im
 525     win connect-signals
 526
 527     win gtk_widget_show_all ;
 528
 529 M: gtk-ui-backend (close-window) ( handle -- )
 530     window>> [ gtk_widget_destroy ] [ unregister-window ] bi
 531     event-loop? [ gtk_main_quit ] unless ;
 532
 533 M: gtk-ui-backend set-title
 534     swap [ handle>> window>> ] [ utf8 string>alien ] bi*
 535     gtk_window_set_title ;
 536
 537 M: gtk-ui-backend (set-fullscreen)
 538     [ handle>> ] dip [ >>fullscreen? ] keep
 539     [ window>> ] dip
 540     [ gtk_window_fullscreen ]
 541     [ gtk_window_unfullscreen ] if ;
 542
 543 M: gtk-ui-backend (fullscreen?)
 544     handle>> fullscreen?>> ;
 545
 546 M: gtk-ui-backend raise-window*
 547     handle>> window>> gtk_window_present ;
 548
 549 : set-cursor ( win cursor -- )
 550     [
 551         [ gtk_widget_get_window ] dip
 552         gdk_cursor_new &gdk_cursor_unref
 553         gdk_window_set_cursor
 554     ] with-destructors ;
 555
 556 M: gtk-ui-backend (grab-input)
 557     window>>
 558     [ gtk_grab_add ] [ GDK_BLANK_CURSOR set-cursor ] bi ;
 559
 560 M: gtk-ui-backend (ungrab-input)
 561     window>>
 562     [ gtk_grab_remove ] [ GDK_LEFT_PTR set-cursor ] bi ;
 563
 564 M: window-handle select-gl-context ( handle -- )
 565     window>>
 566     [ gtk_widget_get_gl_window ] [ gtk_widget_get_gl_context ] bi
 567     gdk_gl_drawable_make_current drop ;
 568
 569 M: window-handle flush-gl-context ( handle -- )
 570     window>> gtk_widget_get_gl_window
 571     gdk_gl_drawable_swap_buffers ;
 572
 573 M: gtk-ui-backend beep
 574     gdk_beep ;
 575
 576 M:: gtk-ui-backend system-alert ( caption text -- )
 577     f GTK_DIALOG_MODAL GTK_MESSAGE_WARNING GTK_BUTTONS_OK
 578     caption utf8 string>alien f gtk_message_dialog_new
 579     [ text utf8 string>alien f gtk_message_dialog_format_secondary_text ]
 580     [ gtk_dialog_run drop ]
 581     [ gtk_widget_destroy ] tri ;
 582
 583 M: gtk-clipboard clipboard-contents
 584     [
 585         handle>> gtk_clipboard_wait_for_text
 586         [ &g_free utf8 alien>string ] [ f ] if*
 587     ] with-destructors ;
 588
 589 M: gtk-clipboard set-clipboard-contents
 590     swap [ handle>> ] [ utf8 string>alien ] bi*
 591     -1 gtk_clipboard_set_text ;
 592
 593 gtk-ui-backend ui-backend set-global
 594
 595 [ "ui.tools" ] main-vocab-hook set-global