[graphic-forms-cvs] r241 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Aug 28 22:52:56 UTC 2006
Author: junrue
Date: Mon Aug 28 18:52:53 2006
New Revision: 241
Modified:
trunk/docs/manual/widget-functions.texinfo
trunk/docs/manual/widget-types.texinfo
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/item-manager.lisp
trunk/src/uitoolkit/widgets/item.lisp
trunk/src/uitoolkit/widgets/menu-item.lisp
trunk/src/uitoolkit/widgets/menu-language.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
Log:
item-manager now has slots for functions to obtain text and image from item data, revised append-item accordingly
Modified: trunk/docs/manual/widget-functions.texinfo
==============================================================================
--- trunk/docs/manual/widget-functions.texinfo (original)
+++ trunk/docs/manual/widget-functions.texinfo Mon Aug 28 18:52:53 2006
@@ -10,25 +10,27 @@
@anchor{ancestor-p}
@deffn GenericFunction ancestor-p ancestor descendant => boolean
-Returns T if @var{ancestor} is the parent of @var{descendant}; nil otherwise.
+Returns T if @var{ancestor} is the parent of @var{descendant}; @sc{nil}
+otherwise.
@end deffn
@anchor{append-item}
- at deffn GenericFunction append-item self text image dispatcher &optional disabled checked
-Adds the new item with the specified @code{text}, @code{image}, and
- at ref{event-dispatcher} to the object, and returns the newly-created item.
-The optional @code{checked} and @code{disabled} arguments can be used
-to set the item's initial state.
- at end deffn
-
- at deffn GenericFunction append-separator self
-Adds a separator item to the object, and returns the newly-created
-item.
- at end deffn
-
- at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked
-Adds a submenu anchored to a parent menu and returns the corresponding
-menu item. The optional @code{checked} and @code{disabled} arguments can
+ at deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item}
+Adds a new item representing @var{thing} to @var{self}, where the
+class of @var{self} must derive from @ref{item-manager}. The
+newly-created item is returned. The @var{dispatcher} parameter must
+be an instance of @ref{event-dispatcher} or a subclass thereof. The
+optional @var{checked} and @var{disabled} arguments can be used to set
+the item's initial state.
+ at end deffn
+
+ at deffn GenericFunction append-separator self => @ref{item}
+Adds a separator item to @var{self}, and returns the newly-created item.
+ at end deffn
+
+ at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item}
+Adds @var{submenu} anchored to @var{self} and returns the corresponding
+ at ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can
be used to set the menu item's initial state.
@end deffn
Modified: trunk/docs/manual/widget-types.texinfo
==============================================================================
--- trunk/docs/manual/widget-types.texinfo (original)
+++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 18:52:53 2006
@@ -60,24 +60,35 @@
@end deftp
@anchor{item}
- at deftp Class item item-id
+ at deftp Class item data item-id
This is the base class for all non-windowed user
interface objects serving as subcomponents of an
@ref{item-manager}. It derives from @ref{event-source}.
@table @var
+ at item data
+A reference to the application-defined object to be wrapped
+by the item.
@item item-id
An identifier for the item managed internally by Graphic-Forms.
@end table
@end deftp
@anchor{item-manager}
- at deftp Class item-manager items
+ at deftp Class item-manager image-provider items text-provider
This is is a mix-in class for @ref{widget}s containing sub-elements.
-
@table @var
+ at item image-provider
+This slot holds a function accepting one argument and returning an
+instance of @ref{image}. The default implementation simply
+returns @sc{nil}.
@item items
An @sc{adjustable} @sc{vector} containing @ref{item}s representing
sub-elements.
+ at item text-provider
+This slot holds a function accepting one argument and returning a
+ at sc{string}. The default implementation checks whether the argument
+is already a @sc{string}, and if so just returns it; otherwise it
+calls @sc{format}.
@end table
@end deftp
@@ -356,10 +367,8 @@
@end deffn
@deffn Initarg :initial-items
This initarg accepts a list of objects for initially populating the
-contents of the list-box. @sc{print-object} will be called for
-each object to produce the corresponding item's display string.
-The list-box will hold references to the supplied objects. See
-also @ref{append-item}.
+contents of the list-box. The list-box will hold references to the
+supplied objects. See also @ref{append-item}.
@end deffn
@control-parent-initarg{list-box}
@deffn Initarg :style
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Aug 28 18:52:53 2006
@@ -177,7 +177,7 @@
(gfw:mapchildren *layout-tester-win*
(lambda (parent child)
(declare (ignore parent))
- (let ((it (gfw::append-item menu (gfw:text child) nil nil)))
+ (let ((it (gfw::append-item menu (gfw:text child) nil)))
(unless (null (sub-disp-class-of d))
(setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d))))
(unless (null (check-test-fn d))
@@ -378,9 +378,9 @@
(gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items)
(gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items)
(let ((style (gfw:style-of (gfw:layout-of *layout-tester-win*))))
- (setf it (gfw:append-item menu "Normalize" nil #'set-flow-layout-normalize))
+ (setf it (gfw:append-item menu "Normalize" #'set-flow-layout-normalize))
(gfw:check it (find :normalize style))
- (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap))
+ (setf it (gfw:append-item menu "Wrap" #'set-flow-layout-wrap))
(gfw:check it (find :wrap style)))))
(defun exit-layout-callback (disp item)
Modified: trunk/src/uitoolkit/widgets/item-manager.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item-manager.lisp (original)
+++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Aug 28 18:52:53 2006
@@ -33,8 +33,27 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defmethod append-item :before ((self item-manager) text (image gfg:image) (disp event-dispatcher) &optional checked disabled)
- (declare (ignore text image disp checked disabled))
+;;;
+;;; helper functions
+;;;
+
+(defun call-text-provider (manager thing)
+ (let ((func (text-provider-of manager))
+ (*print-readably* nil))
+ (cond
+ ((stringp thing)
+ thing)
+ ((null func)
+ (format nil "~a" thing))
+ (t
+ (funcall func thing)))))
+
+;;;
+;;; methods
+;;;
+
+(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled)
+ (declare (ignore thing disp checked disabled))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
Modified: trunk/src/uitoolkit/widgets/item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item.lisp (original)
+++ trunk/src/uitoolkit/widgets/item.lisp Mon Aug 28 18:52:53 2006
@@ -32,7 +32,7 @@
;;;;
(in-package :graphic-forms.uitoolkit.widgets)
-
+
(defun items-equal-p (item1 item2)
(= (item-id item1) (item-id item2)))
Modified: trunk/src/uitoolkit/widgets/menu-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-item.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-item.lisp Mon Aug 28 18:52:53 2006
@@ -166,15 +166,15 @@
(error 'gfs:win32-error :detail "set-menu-item-info failed"))
(= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+))))
-(defun create-menuitem-with-callback (hmenu disp)
+(defun create-menuitem-with-callback (hmenu thing disp)
(let ((item nil))
(cond
((null disp)
- (setf item (make-instance 'menu-item :handle hmenu)))
+ (setf item (make-instance 'menu-item :data thing :handle hmenu)))
((functionp disp)
- (setf item (make-instance 'menu-item :handle hmenu :callback disp)))
+ (setf item (make-instance 'menu-item :data thing :handle hmenu :callback disp)))
((typep disp 'gfw:event-dispatcher)
- (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp)))
+ (setf item (make-instance 'menu-item :data thing :handle hmenu :dispatcher disp)))
(t
(error 'gfs:toolkit-error
:detail "callback must be a function, instance of gfw:event-dispatcher, or null")))
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Aug 28 18:52:53 2006
@@ -167,6 +167,8 @@
;;; code generation
;;;
+(defstruct menu-item-data text image)
+
(defun generate-menusystem-code (sexp generator-sym)
(let ((code nil))
(mapcar #'(lambda (var)
@@ -177,19 +179,25 @@
(defclass win32-menu-generator (base-menu-generator) ())
(defmethod initialize-instance :after ((gen win32-menu-generator) &key)
- (let ((m (make-instance 'menu :handle (gfs::create-menu))))
+ (let ((m (make-instance 'menu :handle (gfs::create-menu)
+ :image-provider #'menu-item-data-image
+ :text-provider #'menu-item-data-text)))
(put-widget (thread-context) m)
(push m (menu-stack-of gen))))
(defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image)
- (append-item (first (menu-stack-of gen)) label image dispatcher disabled checked))
+ (append-item (first (menu-stack-of gen))
+ (make-menu-item-data :text label :image image)
+ dispatcher disabled checked))
(defmethod define-separator ((gen win32-menu-generator))
(let ((owner (first (menu-stack-of gen))))
(append-separator owner)))
(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
- (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))))
+ (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)
+ :image-provider #'menu-item-data-image
+ :text-provider #'menu-item-data-text)))
(append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled)
(push submenu (menu-stack-of gen))))
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Mon Aug 28 18:52:53 2006
@@ -90,12 +90,12 @@
;;; methods
;;;
-(defmethod append-item ((owner menu) text image disp &optional disabled checked)
- (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items
+(defmethod append-item ((owner menu) thing disp &optional disabled checked)
(let* ((tc (thread-context))
(id (increment-menuitem-id tc))
(hmenu (gfs:handle owner))
- (item (create-menuitem-with-callback hmenu disp)))
+ (item (create-menuitem-with-callback hmenu thing disp))
+ (text (call-text-provider owner thing)))
(insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked)
(setf (item-id item) id)
(put-menuitem tc item)
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Aug 28 18:52:53 2006
@@ -80,6 +80,10 @@
:accessor item-id
:initarg :item-id
:initform 0)
+ (data
+ :accessor data-of
+ :initarg :data
+ :initform nil)
(callback-event-name
:accessor callback-event-name-of
:initform 'event-select
@@ -158,7 +162,15 @@
((items
:accessor items
;; FIXME: allow subclasses to set initial size?
- :initform (make-array 7 :fill-pointer 0 :adjustable t)))
+ :initform (make-array 7 :fill-pointer 0 :adjustable t))
+ (text-provider
+ :accessor text-provider-of
+ :initarg :text-provider
+ :initform nil)
+ (image-provider
+ :accessor image-provider-of
+ :initarg :image-provider
+ :initform nil))
(:documentation "A mix-in for objects composed of sub-elements."))
(defclass list-box (widget item-manager)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Aug 28 18:52:53 2006
@@ -45,8 +45,8 @@
(defgeneric ancestor-p (ancestor descendant)
(:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise."))
-(defgeneric append-item (self text image dispatcher &optional checked disabled)
- (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item."))
+(defgeneric append-item (self thing dispatcher &optional checked disabled)
+ (:documentation "Adds a new item encapsulating thing to self, and returns the newly-created item."))
(defgeneric append-separator (self)
(:documentation "Add a separator item to the object, and returns the newly-created item."))
More information about the Graphic-forms-cvs
mailing list