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} -@deffn GenericFunction append-item self text image dispatcher &optional disabled checked -Adds the new item with the specified @code{text}, @code{image}, and -@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. -@end deffn - -@deffn GenericFunction append-separator self -Adds a separator item to the object, and returns the newly-created -item. -@end deffn - -@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 +@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. +@end deffn + +@deffn GenericFunction append-separator self => @ref{item} +Adds a separator item to @var{self}, and returns the newly-created item. +@end deffn + +@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item} +Adds @var{submenu} anchored to @var{self} and returns the corresponding +@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} -@deftp Class item item-id +@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 +@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} -@deftp Class item-manager items +@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 +@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. +@item text-provider +This slot holds a function accepting one argument and returning a +@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."))