gtk/gtk.widget.lisp

   1 (in-package :gtk)
   2
   3 ; TODO: GtkWidget
   4
   5 (defun widget-flags (widget)
   6   (convert-from-foreign (gtk-object-flags-as-integer widget) 'widget-flags))
   7
   8 (defun (setf widget-flags) (new-value widget)
   9   (setf (gtk-object-flags-as-integer widget)
  10         (convert-to-foreign new-value 'widget-flags))
  11   new-value)
  12
  13 (export 'widget-flags)
  14
  15 (defcstruct %gtk-requisition
  16   (:width :int)
  17   (:height :int))
  18
  19 (defcstruct %gtk-allocation
  20   (:x :int)
  21   (:y :int)
  22   (:width :int)
  23   (:height :int))
  24
  25 (defcstruct %gtk-widget
  26   (:object %gtk-object)
  27   (:private-flags :uint16)
  28   (:state state-type)
  29   (:saved-state state-type)
  30   (:name (:pointer :char))
  31   (:style :pointer)
  32   (:requisition %gtk-requisition)
  33   (:allocation %gtk-allocation)
  34   (:window :pointer)
  35   (:parent :pointer))
  36
  37 (defun widget-state (widget)
  38   (foreign-slot-value (pointer widget) '%gtk-widget :state))
  39
  40 (export 'widget-state)
  41 (defun widget-saved-state (widget)
  42   (foreign-slot-value (pointer widget) '%gtk-widget :saved-state))
  43
  44 (export 'widget-saved-state)
  45
  46 (defmacro widget-p-fn (type)
  47   (let ((name (intern (format nil "WIDGET-~A-P" (symbol-name type)) (find-package :gtk))))
  48     `(progn (defun ,name (widget)
  49               (member ,type (widget-flags widget)))
  50             (export ',name))))
  51
  52 (widget-p-fn :toplevel)
  53 (widget-p-fn :no-window)
  54 (widget-p-fn :realized)
  55 (widget-p-fn :mapped)
  56 (widget-p-fn :visible)
  57 (widget-p-fn :sensitive)
  58 (widget-p-fn :parent-sensitive)
  59 (widget-p-fn :can-focus)
  60 (widget-p-fn :has-focus)
  61 (widget-p-fn :can-default)
  62 (widget-p-fn :has-default)
  63 (widget-p-fn :has-grab)
  64 (widget-p-fn :rc-style)
  65 (widget-p-fn :composite-child)
  66 (widget-p-fn :no-reparent)
  67 (widget-p-fn :app-paintable)
  68 (widget-p-fn :receives-default)
  69 (widget-p-fn :double-buffered)
  70 (widget-p-fn :no-show-all)
  71
  72 (defcfun (widget-unparent "gtk_widget_unparent") :void
  73   (widget g-object))
  74
  75 (export 'widget-unparent)
  76
  77 (defcfun gtk-widget-show :void
  78   (widget g-object))
  79
  80 (defcfun gtk-widget-show-all :void
  81   (widget g-object))
  82
  83 (defun widget-show (widget &key (all t))
  84   (if all
  85       (gtk-widget-show-all widget)
  86       (gtk-widget-show widget)))
  87
  88 (export 'widget-show)
  89
  90 (defcfun (widget-show-now "gtk_widget_show_now") :void
  91   (widget g-object))
  92
  93 (export 'widget-show-now)
  94
  95 (defcfun gtk-widget-hide :void
  96   (widget g-object))
  97
  98 (defcfun gtk-widget-hide-all :void
  99   (widget g-object))
 100
 101 (defun widget-hide (widget &key (all t))
 102   (if all
 103       (gtk-widget-hide-all widget)
 104       (gtk-widget-hide widget)))
 105
 106 (defcfun (widget-map "gtk_widget_map") :void
 107   (widget g-object))
 108
 109 (export 'widget-map)
 110
 111 (defcfun (widget-unmap "gtk_widget_unmap") :void
 112   (widget g-object))
 113
 114 (export 'widget-unmap)
 115
 116 (defcfun (widget-realize "gtk_widget_realize") :void
 117   (width g-object))
 118
 119 (export 'widget-realize)
 120
 121 (defcfun (widget-unrealize "gtk_widget_unrealize") :void
 122   (width g-object))
 123
 124 (export 'widget-unrealize)
 125
 126 (defcfun (widget-queue-draw "gtk_widget_queue_draw") :void
 127   (widget (g-object widget)))
 128
 129 (export 'widget-queue-draw)
 130
 131 (defcfun (widget-queue-resize "gtk_widget_queue_resize") :void
 132   (widget (g-object widget)))
 133
 134 (export 'widget-queue-resize)
 135
 136 (defcfun (widget-queue-resize-no-redraw "gtk_widget_queue_resize_no_redraw") :void
 137   (widget (g-object widget)))
 138
 139 (export 'widget-queue-resize-no-redraw)
 140
 141 ; TODO: gtk_widget_get_child_requisition
 142
 143 ; TODO: gtk_widget_size_allocate
 144
 145 (defcfun (widget-add-accelerator "gtk_widget_add_accelerator") :void
 146   (widget g-object)
 147   (accel-signal :string)
 148   (accel-group g-object)
 149   (accel-key :uint)
 150   (accel-mods modifier-type)
 151   (accel-flags accel-flags))
 152
 153 (export 'widget-add-accelerator)
 154
 155 (defcfun (widget-remove-accelerator "gtk_widget_remove_accelerator") :void
 156   (widget g-object)
 157   (accel-group g-object)
 158   (accel-key :uint)
 159   (accel-mods modifier-type))
 160
 161 (export 'widget-remove-accelerator)
 162
 163 (defcfun (widget-set-accel-path "gtk_widget_set_accel_path") :void
 164   (widget g-object)
 165   (accel-path :string)
 166   (accel-group g-object))
 167
 168 (export 'widget-set-accel-path)
 169
 170 ; TODO: gtk_widget_list_accel_closures
 171
 172 (defcfun gtk-widget-can-activate-accel :boolean
 173   (widget g-object)
 174   (signal-id :uint))
 175
 176 (defun widget-can-activate-accel (widget signal)
 177   (when (stringp signal) (setf signal (g-signal-lookup signal (g-type-from-object widget))))
 178   (gtk-widget-can-activate-accel widget signal))
 179
 180 (export 'widget-can-activate-accel)
 181
 182 ; TODO: gtk_widget_event
 183
 184 (defcfun (widget-activate "gtk_widget_activate") :boolean
 185   (widget g-object))
 186
 187 (export 'widget-activate)
 188
 189 (defcfun (widget-reparent "gtk_widget_reparent") :void
 190   (widget g-object)
 191   (new-parent g-object))
 192
 193 (export 'widget-reparent)
 194
 195 (defcfun gtk-widget-intersect :boolean
 196   (widget g-object)
 197   (area (g-boxed-foreign rectangle))
 198   (intersection (g-boxed-foreign rectangle :in-out)))
 199
 200 (defun widget-intersect (widget rectangle)
 201   (let ((result (make-rectangle :x 0 :y 0 :width 0 :height 0)))
 202     (when (gtk-widget-intersect widget rectangle result)
 203       result)))
 204
 205 (export 'widget-intersect)
 206
 207 (defcfun (widget-focus-p "gtk_widget_is_focus") :boolean
 208   (widget g-object))
 209
 210 (export 'widget-focus-p)
 211
 212 (defcfun (widget-grab-focus "gtk_widget_grab_focus") :void
 213   (widget g-object))
 214
 215 (export 'widget-grab-focus)
 216
 217 (defcfun (widget-grab-default "gtk_widget_grab_default") :void
 218   (widget g-object))
 219
 220 (export 'widget-grab-default)
 221
 222 ; TODO: gtk_widget_set_state
 223
 224 ; TODO: gtk_widget_set_parent_window
 225
 226 ; TODO: gtk_widget_get_parent_window
 227
 228 ; TODO: gtk_widget_set_extension_events
 229
 230 ; TODO: gtk_widget_get_extension_events
 231
 232
 233 ; fix ownership issues:
 234 ; TODO: gtk_widget_get_toplevel
 235
 236 ; TODO: gtk_widget_get_ancestor
 237
 238 ; TODO: gtk_widget_get_colormap
 239
 240 ; TODO: gtk_widget_get_visual
 241
 242 (defcfun gtk-widget-get-pointer :void
 243   (widget g-object)
 244   (x (:pointer :int))
 245   (y (:pointer :int)))
 246
 247 (defun widget-pointer (widget)
 248   (with-foreign-objects ((x :int) (y :int))
 249     (gtk-widget-get-pointer widget x y)
 250     (values (mem-ref x :int) (mem-ref y :int))))
 251
 252 (export 'widget-pointer)
 253
 254 (defcfun (widget-contained-p "gtk_widget_is_ancestor") :boolean
 255   (widget g-object)
 256   (container g-object))
 257
 258 (export 'widget-contained-p)
 259
 260 (defcfun gtk-widget-translate-coordinates :boolean
 261   (src-widget g-object)
 262   (dst-widget g-object)
 263   (src-x :int)
 264   (src-y :int)
 265   (dst-x (:pointer :int))
 266   (dst-y (:pointer :int)))
 267
 268 (defun widget-translate-coordinates (src-widget dst-widget src-x src-y)
 269   (with-foreign-objects ((dst-x :int) (dst-y :int))
 270     (gtk-widget-translate-coordinates src-widget dst-widget src-x src-y dst-x dst-y)
 271     (values (mem-ref dst-x :int)
 272             (mem-ref dst-y :int))))
 273
 274 (export 'widget-translate-coordinates)
 275
 276 (defcfun (widget-ensure-style "gtk_widget_ensure_style") :void
 277   (widget g-object))
 278
 279 (export 'widget-ensure-style)
 280
 281 (defcfun (widget-reset-rc-styles "gtk_widget_reset_rc_styles") :void
 282   (widget g-object))
 283
 284 (export 'widget-reset-rc-styles)
 285
 286 ; TODO: gtk_widget_push_colormap
 287
 288 ; TODO: gtk_widget_pop_colormap
 289
 290 ; TODO: gtk_widget_set_default_colormap
 291
 292 ; TODO: gtk_widget_get_default_colormap
 293
 294 ; TODO: gtk_widget_get_default_style (ownership)
 295
 296 ; TODO: gtk_widget_get_default_visual
 297
 298 (defcfun (widget-default-direction "gtk_widget_get_default_direction") text-direction)
 299
 300 (defcfun gtk-widget-set-default-direction :void
 301   (direction text-direction))
 302
 303 (defun (setf widget-default-direction) (new-value)
 304   (gtk-widget-set-default-direction new-value))
 305
 306 (export 'widget-default-direction)
 307
 308 ; TODO: gtk_widget_shape_combine_mask
 309
 310 ; TODO: gtk_widget_input_shape_combine_mask
 311
 312 (defcfun gtk-widget-path :void
 313   (widget g-object)
 314   (path-length (:pointer :uint))
 315   (path (:pointer (:pointer :char)))
 316   (path-reversed (:pointer (:pointer :char))))
 317
 318 (defcfun gtk-widget-class-path :void
 319   (widget g-object)
 320   (path-length (:pointer :uint))
 321   (path (:pointer (:pointer :char)))
 322   (path-reversed (:pointer (:pointer :char))))
 323
 324 (defun widget-path (widget &key (path-type :name))
 325   (assert (typep path-type '(member :name :class)))
 326   (with-foreign-object (path :pointer)
 327     (ecase path-type
 328       (:name (gtk-widget-path widget (null-pointer) path (null-pointer)))
 329       (:class (gtk-widget-class-path widget (null-pointer) path (null-pointer))))
 330     (mem-ref path '(g-string :free-from-foreign t))))
 331
 332 (export 'widget-path)
 333
 334 ; TODO: gtk_widget_modify_style
 335
 336 ; TODO: gtk_widget_get_modifier_style
 337
 338 ; TODO: gtk_widget_modify_fg
 339
 340 ; TODO: gtk_widget_modify_bg
 341
 342 ; TODO: gtk_widget_modify_text
 343
 344 ; TODO: gtk_widget_modify_base
 345
 346 ; TODO: gtk_widget_modify_font
 347
 348 ; TODO: gtk_widget_modify_cursor
 349
 350 (defcfun (widget-create-pango-context "gtk_widget_create_pango_context") g-object
 351   (widget g-object))
 352
 353 (export 'widget-create-pango-context)
 354
 355 (defcfun (widget-get-pango-context "gtk_widget_get_pango_context") g-object
 356   (widget g-object))
 357
 358 (export 'widget-get-pango-context)
 359
 360 (defcfun (widget-create-pango-layout "gtk_widget_create_pango_layout") (g-object gdk::pango-layout :already-referenced)
 361   (widget (g-object widget))
 362   (text :string))
 363
 364 (export 'widget-create-pango-layout)
 365
 366 (defcfun (widget-render-icon "gtk_widget_render_icon") g-object
 367   (widget g-object)
 368   (stock-id :string)
 369   (size icon-size)
 370   (detail :string))
 371
 372 (export 'widget-render-icon)
 373
 374 (defcfun (widget-push-composite-child "gtk_widget_push_composite_child") :void
 375   (widget g-object))
 376
 377 (export 'widget-push-composite-child)
 378
 379 (defcfun (widget-pop-composite-child "gtk_widget_pop_composite_child") :void
 380   (widget g-object))
 381
 382 (export 'widget-pop-composite-child)
 383
 384 (defcfun (widget-queue-draw-area "gtk_widget_queue_draw_area") :void
 385   (widget g-object)
 386   (x :int)
 387   (y :int)
 388   (width :int)
 389   (height :int))
 390
 391 (export 'widget-queue-draw-area)
 392
 393 (defcfun (widget-reset-shapes "gtk_widget_reset_shapes") :void
 394   (widget g-object))
 395
 396 (export 'widget-reset-shapes)
 397
 398 (defcfun (widget-set-scroll-adjustments "gtk_widget_set_scroll_adjustments") :boolean
 399   (widget g-object)
 400   (hadjustment g-object)
 401   (vadjustment g-object))
 402
 403 (export 'widget-set-scroll-adjustments)
 404
 405 ; TODO: gtk_widget_class_install_style_property
 406
 407 ; TOOD: gtk_widget_class_install_style_property_parser
 408
 409 ; TODO: gtk_widget_class_list_style_properties
 410
 411 ; TODO: gtk_widget_region_intersect
 412
 413 ; TODO: gtk_widget_send_expose
 414
 415 (defcfun gtk-widget-style-get-property :void
 416   (widget g-object)
 417   (property-name :string)
 418   (value (:pointer g-value)))
 419
 420 (defcfun gtk-widget-class-find-style-property (:pointer g-param-spec)
 421   (class :pointer)
 422   (property-name :string))
 423
 424 (defcfun gtk-widget-class-list-style-properties (:pointer (:pointer g-param-spec))
 425   (class :pointer)
 426   (n-properties (:pointer :int)))
 427
 428 (defun widget-class-get-style-properties (type)
 429   (setf type (ensure-g-type type))
 430   (let ((class (g-type-class-ref type)))
 431     (unwind-protect
 432          (with-foreign-object (np :int)
 433            (let ((specs (gtk-widget-class-list-style-properties class np)))
 434              (unwind-protect
 435                   (loop
 436                      repeat (mem-ref np :int)
 437                      for i from 0
 438                      for spec = (mem-aref specs :pointer i)
 439                      collect (parse-g-param-spec spec))
 440                (g-free specs))))
 441       (g-type-class-unref class))))
 442
 443 (export 'widget-class-get-style-properties)
 444
 445 (defun widget-child-property-type (widget property-name)
 446   (let* ((type (g-type-from-object widget))
 447          (class (g-type-class-ref type)))
 448     (unwind-protect
 449          (let ((g-param-spec (gtk-widget-class-find-style-property class property-name)))
 450            (when (null-pointer-p g-param-spec) (error "Widget ~A has no style-property named '~A'" widget property-name))
 451            (foreign-slot-value g-param-spec 'gobject:g-param-spec :value-type))
 452       (g-type-class-unref class))))
 453
 454 (defun widget-child-property-value (widget property-name &optional property-type)
 455   (unless property-type (setf property-type (widget-child-property-type widget property-name)))
 456   (setf property-type (ensure-g-type property-type))
 457   (with-foreign-object (gvalue 'g-value)
 458     (g-value-zero gvalue)
 459     (g-value-init gvalue property-type)
 460     (prog1 (gtk-widget-style-get-property widget property-name gvalue)
 461       (g-value-unset gvalue))))
 462
 463 (export 'widget-child-property-value)
 464
 465 (defcfun (widget-child-focus "gtk_widget_child_focus") :boolean
 466   (widget g-object)
 467   (direction direction-type))
 468
 469 (export 'widget-child-focus)
 470
 471 (defcfun (widget-freeze-child-notify "gtk_widget_freeze_child_notify") :void
 472   (widget g-object))
 473
 474 (export 'widget-freeze-child-notify)
 475
 476 (defcfun (widget-settings "gtk_widget_get_settings") g-object
 477   (widget g-object))
 478
 479 (export 'widget-settings)
 480
 481 ; TODO: gtk_widget_get_clipboard
 482
 483 (defcfun (widget-display "gtk_widget_get_display") g-object
 484   (widget g-object))
 485
 486 (export 'widget-display)
 487
 488 (defcfun (widget-root-window "gtk_widget_get_root_window") g-object
 489   (widget g-object))
 490
 491 (export 'widget-root-window)
 492
 493 (defcfun (widget-screen "gtk_widget_get_screen") g-object
 494   (widget g-object))
 495
 496 (export 'widget-screen)
 497
 498 (defcfun (widget-has-screen "gtk_widget_has_screen") :boolean
 499   (widget g-object))
 500
 501 (export 'widget-has-screen)
 502
 503 ; TODO: gtk_widget_set_child_visible
 504
 505 (defcfun (widget-thaw-child-notify "gtk_widget_thaw_child_notify") :void
 506   (widget g-object))
 507
 508 (export 'widget-thaw-child-notify)
 509
 510 ; TODO: gtk_widget_list_mnemonic_labels
 511
 512 (defcfun (widget-add-mnemonic-label "gtk_widget_add_mnemonic_label") :void
 513   (widget g-object)
 514   (label g-object))
 515
 516 (export 'widget-add-mnemonic-label)
 517
 518 (defcfun (widget-remove-mnemonic-label "gtk_widget_remove_mnemonic_label") :void
 519   (widget g-object)
 520   (label g-object))
 521
 522 (export 'widget-remove-mnemonic-label)
 523
 524 (defcfun (widget-action "gtk_widget_get_action") g-object
 525   (widget g-object))
 526
 527 (export 'widget-action)
 528
 529 (defcfun (widget-composited-p "gtk_widget_is_composited") :boolean
 530   (widget g-object))
 531
 532 (export 'widget-composited-p)
 533
 534 (defcfun (widget-error-bell "gtk_widget_error_bell") :void
 535   (widget g-object))
 536
 537 (export 'widget-error-bell)
 538
 539 (defcfun (widget-trigger-tooltip-query "gtk_tooltip_trigger_tooltip_query") :void
 540   (widget g-object))
 541
 542 (export 'widget-trigger-tooltip-query)
 543
 544 (defcfun gtk-widget-get-snapshot g-object
 545   (widget g-object)
 546   (clip-rectangle (g-boxed-foreign rectangle)))
 547
 548 (defun widget-snapshot (widget &optional clip-rectangle)
 549   (gtk-widget-get-snapshot widget clip-rectangle))
 550
 551 (export 'widget-snapshot)