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