gtk/gtk.widget.lisp

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