basis/ui/backend/gtk/gtk.factor

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