From: espen <espen>
Date: Thu, 6 Jan 2005 21:05:46 +0000 (+0000)
Subject: New toolbar API
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/cb4bf7725c9512f1001745bdb157e4eddddb9f76

New toolbar API
---

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index f470588..3e623e2 100644
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtk.lisp,v 1.28 2004-12-29 21:17:36 espen Exp $
+;; $Id: gtk.lisp,v 1.29 2005-01-06 21:05:46 espen Exp $
 
 
 (in-package "GTK")
@@ -113,9 +113,11 @@ (defun (setf bin-child) (child bin)
   (container-add bin child)
   child)
 
-
-;;; Binding
-
+(defmethod create-callback-function ((bin bin) function arg1)
+  (if (eq arg1 :child)
+      #'(lambda (&rest args) 
+	  (apply function (bin-child bin) (rest args)))
+    (call-next-method)))
 
 
 ;;; Box
@@ -517,7 +519,7 @@ (defmethod initialize-instance ((image image) &rest initargs &key pixmap file)
       (image-set-from-file image file)))
    ((call-next-method))))
 
-(defun create-image (source &optional mask)
+(defun create-image-widget (source &optional mask)
   (etypecase source
     (gdk:pixbuf (make-instance 'image :pixbuf source))
     (string (make-instance 'image :stock source))
@@ -530,7 +532,7 @@ (defun create-image (source &optional mask)
 
 (defmethod initialize-instance ((item image-menu-item) &rest initargs &key image)
   (if (and image (not (typep image 'widget)))
-      (apply #'call-next-method item :image (create-image image) initargs) 
+      (apply #'call-next-method item :image (create-image-widget image) initargs) 
     (call-next-method)))
 
 
@@ -538,7 +540,7 @@ (defmethod (setf image-menu-item-image) ((widget widget) (item image-menu-item))
   (setf (slot-value item 'image) widget))
 
 (defmethod (setf image-menu-item-image) (image (item image-menu-item))
-  (setf (image-menu-item-image item) (create-image image)))
+  (setf (image-menu-item-image item) (create-image-widget image)))
 
 
 ;;; Label
@@ -569,16 +571,15 @@ (defbinding %radio-button-set-group () nil
   (radio-button radio-button)
   (group pointer))
 
-(defun radio-button-add-to-group (button1 button2)
+(defmethod add-to-radio-group ((button1 radio-button) (button2 radio-button))
   "Add BUTTON1 to the group which BUTTON2 belongs to."
   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 
-
 (defmethod initialize-instance ((button radio-button) &key group)
   (prog1
       (call-next-method)
     (when group
-      (radio-button-add-to-group button group))))
+      (add-to-radio-group button group))))
 
 
 ;;; Item
@@ -702,7 +703,7 @@ (defbinding %radio-menu-item-set-group () nil
   (radio-menu-item radio-menu-item)
   (group pointer))
 
-(defun radio-menu-item-add-to-group (item1 item2)
+(defmethod add-to-radio-group ((item1 radio-menu-item) (item2 radio-menu-item))
   "Add ITEM1 to the group which ITEM2 belongs to."
   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
 
@@ -710,7 +711,8 @@ (defmethod initialize-instance ((item radio-menu-item) &key group)
   (prog1
       (call-next-method)
     (when group
-      (radio-menu-item-add-to-group item group))))
+      (add-to-radio-group item group))))
+
   
 
 ;;; Radio tool button
@@ -722,16 +724,29 @@ (defbinding %radio-tool-button-set-group () nil
   (radio-tool-button radio-tool-button)
   (group pointer))
 
-(defun radio-tool-button-add-to-group (button1 button2)
+(defmethod add-to-radio-group ((button1 radio-tool-button) (button2 radio-tool-button))
   "Add BUTTON1 to the group which BUTTON2 belongs to."
   (%radio-tool-button-set-group button1 (%radio-tool-button-get-group button2)))
 
+(defmethod add-activate-callback ((widget widget) function &key object after)
+  (if object
+      (signal-connect widget 'clicked
+       #'(lambda (object)
+	   (when (slot-value widget 'active)
+	     (funcall function object (slot-value widget 'value))))
+       :object object :after after)
+    (signal-connect widget 'clicked 
+     #'(lambda ()
+	 (when (slot-value widget 'active)
+	   (funcall function (slot-value widget 'value))))
+     :after after)))
 
 (defmethod initialize-instance ((button radio-tool-button) &key group)
   (prog1
       (call-next-method)
     (when group
-      (radio-tool-button-add-to-group button group))))
+      (add-to-radio-group button group))))
+
 
 
 ;;; Toggle button
@@ -1475,119 +1490,83 @@ (defun table-col-spacing (table &optional col)
 
 ;;; Toolbar
 
-(defbinding %toolbar-insert-element () widget
-  (toolbar toolbar)
-  (type toolbar-child-type)
-  (widget (or null widget))
-  (text string)
-  (tooltip-text string)
-  (tooltip-private-text string)
-  (icon (or null widget))
-  (nil null)
-  (nil null)
-  (position int))
+(defmethod initialize-instance ((toolbar toolbar) &rest initargs &key tooltips)
+  (if (eq tooltips t)
+      (apply #'call-next-method toolbar
+       :tooltips (make-instance 'tooltips) initargs)
+    (call-next-method)))
 
-(defbinding %toolbar-insert-stock () widget
+(defbinding %toolbar-insert () nil
   (toolbar toolbar)
-  (stock-id string)
-  (tooltip-text string)
-  (tooltip-private-text string)
-  (nil null)
-  (nil null)
-  (position int))
-
-(defun toolbar-insert (toolbar position element
-		       &key tooltip-text tooltip-private-text
-		       type icon group callback object)
-  (let* ((numpos (case position
-		   (:first -1)
-		   (:last 0)
-		   (t position)))
-	 (widget
-	  (cond
-	   ((or
-	     (eq type :space)
-	     (and (not type) (eq element :space)))
-	    (%toolbar-insert-element
-	     toolbar :space nil nil
-	     tooltip-text tooltip-private-text nil numpos))
-	   ((or
-	     (eq type :widget)
-	     (and (not type) (typep element 'widget)))
-	    (%toolbar-insert-element
-	     toolbar :widget element nil
-	     tooltip-text tooltip-private-text nil numpos))
-	   ((or
-	     (eq type :stock)
-	     (and
-	      (not type)
-	      (typep element 'string)
-	      (stock-lookup element)))
-	    (%toolbar-insert-stock
-	     toolbar element tooltip-text tooltip-private-text numpos))
-	   ((typep element 'string)
-	    (%toolbar-insert-element
-	     toolbar (or type :button) (when (eq type :radio-button) group)
-	     element tooltip-text tooltip-private-text 
-	     (etypecase icon
-	       (null nil)
-	       (widget icon)
-	       (string (make-instance 'image :stock icon))
-	       (pathname (make-instance 'image :file icon))
-	       ((or list vector)
-		(make-instance 'image 
-		 :pixmap icon ; :icon-size (toolbar-icon-size toolbar)
-		 )))
-	     numpos))
-	   ((error "Invalid element type: ~A" element)))))
-    (when callback
-      (signal-connect widget 'clicked callback :object object))
-    widget))
-
-(defun toolbar-append (toolbar element &key tooltip-text tooltip-private-text
-		       type icon group callback object)
-  (toolbar-insert
-   toolbar :first element :type type :icon icon :group group
-   :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
-   :callback callback :object object))
+  (tool-item tool-item)
+  (position position))
 
-(defun toolbar-prepend (toolbar element &key tooltip-text tooltip-private-text
-			type icon group callback object)
-  (toolbar-insert
-   toolbar :last element :type type :icon icon :group group
-   :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
-   :callback callback :object object))
+(defun toolbar-insert (toolbar tool-item &optional (position :end))
+  (%toolbar-insert toolbar tool-item position)
+  (%tool-item-update-tooltips tool-item))
 
+(defbinding toolbar-get-item-index () int
+  (toolbar toolbar)
+  (item tool-item))
 
-(defun toolbar-insert-space (toolbar position)
-  (toolbar-insert toolbar position :space))
+(defbinding toolbar-get-nth-item () tool-item
+  (toolbar toolbar)
+  (n int))
 
-(defun toolbar-append-space (toolbar)
-  (toolbar-append toolbar :space))
+(defbinding toolbar-get-drop-index () int
+  (toolbar toolbar)
+  (x int) (y int))
 
-(defun toolbar-prepend-space (toolbar)
-  (toolbar-prepend toolbar :space))
+(defbinding toolbar-set-drop-highlight-item () nil
+  (toolbar toolbar)
+  (tool-item tool-item)
+  (index int))
 
 
-(defun toolbar-enable-tooltips (toolbar)
-  (setf (toolbar-tooltips-p toolbar) t))
+;;; Tool button
 
-(defun toolbar-disable-tooltips (toolbar)
-  (setf (toolbar-tooltips-p toolbar) nil))
+(defmethod initialize-instance ((button tool-button) &rest initargs &key icon)
+  (if (and icon (not (typep icon 'widget)))
+      (apply #'call-next-method button :icon (create-image-widget icon) initargs)
+    (call-next-method)))
 
 
-(defbinding toolbar-remove-space () nil
-  (toolbar toolbar)
-  (position int))
+;;; Tool item
 
-(defbinding toolbar-unset-icon-size () nil
-  (toolbar toolbar))
+(defbinding tool-item-set-tooltip () nil
+  (tool-item tool-item)
+  (tooltips tooltips)
+  (tip-text string)
+  (tip-private string))
 
-(defbinding toolbar-unset-style () nil
-  (toolbar toolbar))
 
+(defun %tool-item-update-tooltips (tool-item)
+  (when (and 
+	 (slot-boundp tool-item 'parent)
+	 (or 
+	  (user-data-p tool-item 'tip-text)
+	  (user-data-p tool-item 'tip-private)))
+    (tool-item-set-tooltip
+     tool-item (toolbar-tooltips (widget-parent tool-item))
+     (or (user-data tool-item 'tip-text) "")
+     (or (user-data tool-item 'tip-private) ""))))
+
+(defmethod (setf tool-item-tip-text) ((tip-text string) (tool-item tool-item))
+  (setf (user-data tool-item 'tip-text) tip-text)
+  (%tool-item-update-tooltips tool-item)
+  tip-text)
+
+(defmethod (setf tool-item-tip-private) ((tip-private string) (tool-item tool-item))
+  (setf (user-data tool-item 'tip-private) tip-private)
+  (%tool-item-update-tooltips tool-item)
+  tip-private)
+
+(defmethod container-add ((toolbar toolbar) (tool-item tool-item) &rest args)
+  (declare (ignore args))
+  (prog1
+      (call-next-method)
+    (%tool-item-update-tooltips tool-item)))
 
-;;; Tool item
 
 (defbinding tool-item-retrieve-proxy-menu-item () widget
   (tool-item tool-item))
@@ -1627,7 +1606,7 @@ (defbinding editable-insert-text (editable text &optional (position 0)) nil
   (editable editable)
   (text string)
   ((length text) int)
-  (position editable-position :in-out))
+  (position position-type :in-out))
 
 (defun editable-append-text (editable text)
   (editable-insert-text editable text nil))
diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp
index 79eb33b..5a3b811 100644
--- a/gtk/gtktypes.lisp
+++ b/gtk/gtktypes.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtktypes.lisp,v 1.27 2004-12-29 21:17:37 espen Exp $
+;; $Id: gtktypes.lisp,v 1.28 2005-01-06 21:05:46 espen Exp $
 
 
 (in-package "GTK")
@@ -126,7 +126,7 @@ (defclass tree-iter (boxed)
 (deftype tree-path () '(vector integer))
 (register-type 'tree-path "GtkTreePath")
 
-(deftype editable-position () '(or int (enum (:start 0) (:end -1))))
+(deftype position () '(or int (enum (:start 0) (:end -1))))
 
 ;; Forward definitions
 (defclass widget (%object)
@@ -223,7 +223,7 @@ (define-types-by-introspection "Gtk"
      )
     (child-type
      :allocation :virtual
-     :getter "gtk_containerchild_type"
+     :getter "gtk_container_child_type"
      :reader container-child-type
      :type gtype)
     (focus-child
@@ -452,36 +452,54 @@     (default-height :merge t :unbound -1)))
 
   ("GtkToolbar"
    :slots
-   ((tooltips
+   ((show-tooltips
      :allocation :virtual
      :getter "gtk_toolbar_get_tooltips"
      :setter "gtk_toolbar_set_tooltips"
-     :accessor toolbar-tooltips-p
-     :initarg :tooltips
+     :accessor toolbar-show-tooltips-p
+     :initarg :show-tooltips
      :type boolean)
-    (icon-size
+    (tooltips
      :allocation :virtual
-     :getter "gtk_toolbar_get_icon_size"
-     :setter "gtk_toolbar_set_icon_size"
-     :accessor toolbar-icon-size
-     :initarg :icon-size
-     :type icon-size)
+     :getter "gtk_toolbar_get_tooltips_object"
+     :reader toolbar-tooltips
+     :type tooltips)
     (toolbar-style
      :allocation :property
      :pname "toolbar-style"
      :initarg :toolbar-style
      :accessor toolbar-style
-     :type toolbar-style)))
+     :type toolbar-style)
+    (n-items
+     :allocation :virtual
+     :getter "gtk_toolbar_get_n_items"
+     :reader toolbar-n-items
+     :type int)))
 
   ("GtkToolItem"
    :slots
-   ((drag-window
+   ((use-drag-window
      :allocation :virtual
-     :getter "gtk_tool_item_get_drag_window"
-     :setter "gtk_tool_item_set_drag_window"
-     :accessor tool-item-drag-window
+     :getter "gtk_tool_item_get_use_drag_window"
+     :setter "gtk_tool_item_set_use_drag_window"
+     :accessor tool-item-use-drag-window-p
      :initarg :drag-window
-     :type boolean)))
+     :type boolean)
+    (tip-text 
+     :allocation :user-data
+     :setter (setf tool-item-tip-text)
+     :initarg :tip-text
+     :reader tool-item-tip-text)
+    (tip-private
+     :allocation :user-data
+     :setter (setf tool-item-tip-private)
+     :initarg :tip-private
+     :reader tool-item-tip-private)))
+
+  ("GtkToolButton"
+   :slots
+   ((stock-id :merge t :initarg :stock)
+    (icon-widget :merge t :initarg :icon)))
 
   ("GtkToggleToolButton"
    :slots
@@ -499,7 +517,12 @@     (default-height :merge t :unbound -1)))
      :allocation :virtual
      :getter "gtk_radio_tool_button_get_group"
      :reader radio-tool-button-group
-     :type (copy-of (gslist widget)))))
+     :type (copy-of (gslist widget)))
+    (value 
+     :allocation :user-data
+     :initarg :value
+     :accessor radio-tool-button-value
+     :documentation "Value passed as argument to the activate callback")))
 
   ("GtkNotebook"
    :slots
@@ -601,7 +624,12 @@     (default-height :merge t :unbound -1)))
      :allocation :virtual
      :getter "gtk_radio_button_get_group"
      :reader radio-button-group
-     :type (copy-of (gslist widget)))))
+     :type (copy-of (gslist widget)))
+    (value 
+     :allocation :user-data
+     :initarg :value
+     :accessor radio-button-value
+     :documentation "Value passed as argument to the activate callback")))
 
   ("GtkRadioMenuItem"
    :slots
@@ -609,7 +637,12 @@     (default-height :merge t :unbound -1)))
      :allocation :virtual
      :getter "gtk_radio_menu_item_get_group"
      :reader radio-menu-item-group
-     :type (copy-of (gslist widget)))))
+     :type (copy-of (gslist widget)))
+    (value 
+     :allocation :user-data
+     :initarg :value
+     :accessor radio-menu-item-value
+     :documentation "Value passed as argument to the activate callback")))
 
   ("GtkFileSelection"
    :slots
@@ -706,7 +739,7 @@     (default-height :merge t :unbound -1)))
      :setter "gtk_editable_set_position"
      :reader editable-position
      :initarg :position
-     :type editable-position)
+     :type position)
     (text
      :allocation :virtual
      :getter editable-text