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